Loop stops half way

[jhon53]

Hi,

I have the following code that loops through a Column that contains "Failed" and "Passed" in a workbook. I just realized that if in the workbook there are 10 items that have "Failed" and its only copying like 5 of them. for me to get all ten items copied over I have to run it twice and that's a pain when I have a lot of values.

Dim sb As Long
Dim sp As Long
Dim vawbProtLastRow As Long 
Dim vawbBusLastRow As Long
Dim varFile As Variant
Dim i As Long
Dim BusName As String
Dim PDName As String
Dim laymanName As String
Dim laymanNamePd As String
Dim intLastRow As Long
Dim wbBus  As Workbook
Dim wsBus  As Worksheet
Dim wbProt As Workbook
Dim wsProt As Worksheet


       intLastRow = 1
        For i = 1 To 6
              If pwbProject.Sheets("1.1 - Failed").Cells(1048576, i).End(xlUp).Offset(1, 0).Row > intLastRow Then
                 intLastRow = pwbProject.Sheets("1.1 - Failed").Cells(1048576, i).End(xlUp).Offset(1, 0).Row
                End If
        Next i
    
        With pwbProject.Sheets("1.1 - Failed").Range("A2:F" & intLastRow).EntireRow.ClearContents
                End With





'Workbook 1

        PrintLog "Find and open BUS  data file"
            varFile = Dir(ThisWorkbook.Path + "\Software Output Files\" + "*" + strBusDevEvalWb + "?")
                If varFile <> "" Then
                     PrintLog "found " & varFile
                    strBusDevEvalWb = CStr(varFile)
                Else
                    MsgBox "Bus file not found"
                End If
                    Application.DisplayAlerts = False
                    Set wbBus = Workbooks.Open(fileName:=ThisWorkbook.Path + "\Software Output Files\" + strBusDevEvalWb, ReadOnly:=True, UpdateLinks:=False)
                    Set wsBus = wbBus.Worksheets(1)
                    Application.DisplayAlerts = True
                    vawbBusLastRow = wsBus.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
 
    For sb = 3 To vawbBusLastRow
       If wsBus.Cells(sb, 3) = "Failed" Then
            pwbProject.Sheets("1.1 - Failed").Range("A2" & intLastRow).End(xlUp).Offset(1, 0).Value = Cells(sb, 1)
            pwbProject.Sheets("1.1 - Failed").Range("C2" & intLastRow).End(xlUp).Offset(1, 0).Value = CInt(Cells(sb, 5))
            pwbProject.Sheets("1.1 - Failed").Range("D2" & intLastRow).End(xlUp).Offset(1, 0).Value = Format(Cells(sb, 6).Value, "0.00")   'Trim(Left(Cells(sb, 6), 6))
            pwbProject.Sheets("1.1 - Failed").Range("E2" & intLastRow).End(xlUp).Offset(1, 0).Value = CInt(Cells(sb, 7))
                BusName = Trim(wsBus.Cells(sb, 1))
                  If InStr(1, BusName, "Ho_") Then
                        laymanName = "Honda"
                    ElseIf InStr(1, BusName, "T_") Then
                        laymanName = "Toyota"
                    End If
                pwbProject.Sheets("1.1 - Failed").Range("B2" & intLastRow).End(xlUp).Offset(1, 0).Value = laymanName
              End If
      Next sb


'Workbook 2

                varFile = Dir(ThisWorkbook.Path + "\Software Output Files\" + "*" + strPDDevEvalWb + "?")
                    If varFile <> "" Then
                         PrintLog "found " & varFile
                         strPDDevEvalWb = CStr(varFile)
                    Else
                        MsgBox "PD file not found"
                    End If
                        Application.DisplayAlerts = False
                        Set wbProt = Workbooks.Open(fileName:=ThisWorkbook.Path + "\Software Output Files\" + strPDDevEvalWb, ReadOnly:=True)
                       Application.DisplayAlerts = True
                        PrintLog "Creating new PD table sheet"
                        wbProt.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = pdTableSheet
                        Set wsProt = wbProt.Sheets(pdTableSheet)
                        vawbProtLastRow = wbProt.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row - 1




For sp = 2 To vawbProtLastRow
          If wsProt.Cells(sp, 3) = "Failed" Then
            pwbProject.Sheets("1.1 - Failed").Range("A2" & intLastRow + 1).End(xlUp).Offset(1, 0).Value = Cells(sp, 2)
            pwbProject.Sheets("1.1 - Failed").Range("C2" & intLastRow + 1).End(xlUp).Offset(1, 0).Value = CInt(Cells(sp, 5))
            pwbProject.Sheets("1.1 - Failed").Range("D2" & intLastRow + 1).End(xlUp).Offset(1, 0).Value = Cells(sp, 6)
            pwbProject.Sheets("1.1 - Failed").Range("E2" & intLastRow + 1).End(xlUp).Offset(1, 0).Value = CInt(Cells(sp, 7))
                PDName = Trim(wsProt.Cells(sp, 2))
                    If InStr(1, PDName, "M_") Then
                        laymanNamePd = "Male"
                    ElseIf InStr(1, PDName, "F_") Then
                        laymanNamePd = "Female"
                    ElseIf InStr(1, PDName, "U_") Then
                        laymanNamePd = "Unknown"
                    End If
            pwbProject.Sheets("1.1 - Failed").Range("B2" & intLastRow + 1).End(xlUp).Offset(1, 0).Value = laymanNamePd
        End If
      Next sp

any ideas on how i can solve this issue

 

[AlphaFrog]

Try this (not tested)

    Dim sb        As Long
    Dim sp        As Long
    Dim vawbProtLastRow As Long
    Dim vawbBusLastRow As Long
    Dim varFile   As Variant
    Dim i         As Long
    Dim BusName   As String
    Dim PDName    As String
    Dim laymanName As String
    Dim laymanNamePd As String
    Dim intLastRow As Long
    Dim wbBus     As Workbook
    Dim wsBus     As Worksheet
    Dim wbProt    As Workbook
    Dim wsProt    As Worksheet
   
    intLastRow = 2
    With pwbProject.Sheets("1.1 - Failed")
       
        .UsedRange.Offset(1).ClearContents
       
        'Workbook 1
        PrintLog "Find and open BUS  data file"
        varFile = Dir(ThisWorkbook.Path + "\Software Output Files\" + "*" + strBusDevEvalWb + "?")
        If varFile <> "" Then
            PrintLog "found " & varFile
            strBusDevEvalWb = CStr(varFile)
        Else
            MsgBox "Bus file not found"
        End If
       
        Application.DisplayAlerts = False
        Set wbBus = Workbooks.Open(Filename:=ThisWorkbook.Path + "\Software Output Files\" + strBusDevEvalWb, ReadOnly:=True, UpdateLinks:=False)
        Set wsBus = wbBus.Worksheets(1)
        Application.DisplayAlerts = True
       
        vawbBusLastRow = wsBus.Cells(Rows.Count, 1).End(xlUp).Row
        For sb = 3 To vawbBusLastRow
            If LCase(Trim(wsBus.Cells(sb, 3))) = "failed" Then
                .Range("A" & intLastRow).Value = wsBus.Cells(sb, 1)
                .Range("C" & intLastRow).Value = CInt(wsBus.Cells(sb, 5))
                .Range("D" & intLastRow).Value = Format(wsBus.Cells(sb, 6).Value, "0.00")    'Trim(Left(Cells(sb, 6), 6))
                .Range("E" & intLastRow).Value = CInt(wsBus.Cells(sb, 7))
                BusName = Trim(wsBus.Cells(sb, 1))
                If InStr(1, BusName, "Ho_") Then
                    laymanName = "Honda"
                ElseIf InStr(1, BusName, "T_") Then
                    laymanName = "Toyota"
                End If
                .Range("B" & intLastRow).Value = laymanName
                intLastRow = intLastRow + 1
            End If
        Next sb
       
       
        'Workbook 2
        varFile = Dir(ThisWorkbook.Path + "\Software Output Files\*" + strPDDevEvalWb + "?")
        If varFile <> "" Then
            PrintLog "found " & varFile
            strPDDevEvalWb = CStr(varFile)
        Else
            MsgBox "PD file not found"
        End If
        Application.DisplayAlerts = False
        Set wbProt = Workbooks.Open(Filename:=ThisWorkbook.Path + "\Software Output Files\" + strPDDevEvalWb, ReadOnly:=True)
        Application.DisplayAlerts = True
       
        PrintLog "Creating new PD table sheet"
        wbProt.Sheets.Add(After:=wbProt.Worksheets(wbProt.Worksheets.Count)).Name = pdTableSheet
        Set wsProt = wbProt.Sheets(pdTableSheet)
       
        vawbProtLastRow = wbProt.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row - 1
        For sp = 2 To vawbProtLastRow
            If LCase(Trim(wsProt.Cells(sp, 3))) = "failed" Then
                .Range("A" & intLastRow).Value = wsProt.Cells(sp, 2)
                .Range("C" & intLastRow).Value = CInt(wsProt.Cells(sp, 5))
                .Range("D" & intLastRow).Value = wsProt.Cells(sp, 6)
                .Range("E" & intLastRow).Value = CInt(wsProt.Cells(sp, 7))
                PDName = Trim(wsProt.Cells(sp, 2))
                If InStr(1, PDName, "M_") Then
                    laymanNamePd = "Male"
                ElseIf InStr(1, PDName, "F_") Then
                    laymanNamePd = "Female"
                ElseIf InStr(1, PDName, "U_") Then
                    laymanNamePd = "Unknown"
                End If
                .Range("B" & intLastRow).Value = laymanNamePd
                intLastRow = intLastRow + 1
            End If
        Next sp
       
    End With