Home Excel VBA For loop running too fast? Skipping delete row
Reply: 0

Excel VBA For loop running too fast? Skipping delete row

user3441 Published in July 21, 2018, 1:46 pm

Tried searching but nothing seems to specifically answer what I'm after..

For some reason it seems the code is running too fast and skipping the code within the IF section.

So far I've tried adding Application.Wait, creating a separate sub with the IF'd code to be called out in an effort to slow it down. Nothing has proved successful.

The basic purpose is to import a sheet, copy it to the active workbook, then delete rows which are red and finish by deleting the imported sheets.

Everything works except the red rows remain on the target sheet.

Stepping through the process with F8 yields a successful result!

Sub Grab_Data()
Dim StartTime As Double
Dim MinutesElapsed As String
Application.ScreenUpdating = False
Application.Calculation = xlManual
Application.DisplayAlerts = False

Dim targetWorkbook As Workbook

'Assume active workbook as the destination workbook
Set targetWorkbook = Application.ActiveWorkbook

'Import the Metadata
Dim sImportFile As String, sFile As String
Dim sThisBk As Workbook
Dim vfilename As Variant
Set sThisBk = ActiveWorkbook
sImportFile = Application.GetOpenFilename( _
FileFilter:="Microsoft Excel Workbooks, *.xlsm; *.xlsx", Title:="Open 
If sImportFile = "False" Then
MsgBox "No File Selected!"
Exit Sub

vfilename = Split(sImportFile, "\")
sFile = vfilename(UBound(vfilename))
Application.Workbooks.Open Filename:=sImportFile

StartTime = Timer

Set wbBk = Workbooks(sFile)
With wbBk

If SheetExists("TV") Then
Set wsSht = .Sheets("TV")
wsSht.Copy after:=sThisBk.Sheets(Sheets.Count)
ActiveSheet.Name = "TV 2"
MsgBox "There is no sheet with name :TV in:" & vbCr & .Name
End If

wbBk.Close SaveChanges:=False
End With
End If

Set wsSht = Nothing
Set sThisBk = Nothing

'Set sheets to TV
Dim targetSheet As Worksheet
Set targetSheet = targetWorkbook.Worksheets("TV")
Dim sourceSheet As Worksheet
Set sourceSheet = targetWorkbook.Worksheets("TV 2")

'Find Last Rows
Dim LastRow As Long
With sourceSheet
    LastRow = .Cells(rows.Count, "A").End(xlUp).Row
End With

Dim LastRow2 As Long
With targetSheet
    LastRow2 = .Cells(rows.Count, "C").End(xlUp).Row
End With

'Remove RED expired rows
With sourceSheet

For iCntr = LastRow To 1 Step -1

If Cells(iCntr, 2).Interior.ColorIndex = 3 Then


    Debug.Print iCntr
End If


End With

'Variables for TV

targetSheet.Range("B4:B" & LastRow).Value = sourceSheet.Range("E2:E" & 
sourceSheet.Range("E2:E" & LastRow).Copy
targetSheet.Range("B4:B" & LastRow).PasteSpecial xlFormats

Set targetSheet = Nothing
Set sourceSheet = Nothing

'Delete imported sheets
With ActiveWorkbook
.Sheets("TV 2").Delete
.Sheets("Movies 2").Delete
.Sheets("Audio 2").Delete
End With

LastRow = Sheets("TV").Cells(rows.Count, "B").End(xlUp).Row

End With

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")

MsgBox "This code ran successfully in " & MinutesElapsed & " minutes", 

End Sub

Private Function SheetExists(sWSName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = Worksheets(sWSName)
If Not ws Is Nothing Then SheetExists = True
End Function
You need to login account before you can post.

About| Privacy statement| Terms of Service| Advertising| Contact us| Help| Sitemap|
Processed in 0.304699 second(s) , Gzip On .

© 2016 Powered by mzan.com design MATCHINFO