VBA Loop getting break automatically

[vaibhavagar]

Objective:

The objective of the below code is to pull relevant datapoints from all spreadsheets stored in a destination folder

Hence the code asks the user to select the folder, open all thefiles available in the folder one by one, pull the data as per pre-definedcells and copy in the new spreadsheet


Issue:
I am testing the code on a folder having 73 files, sometimesthe code is working perfectly fine for the same folder however sometimes itstops at the loop level where it opens the source workbook and does not proceedfurther.


No error message is displayed. There is no fixed pattern,sometimes it stops after completing 20 worksheets, sometimes after 45 etc.Also, every time it stops, it is a different source workbook hence no issuewith particular source workbook.


Any thoughts what could be the potential issue?



I think it could be due to excel memory getting full, anythoughts how to clear memory or any other code clean-up/optimization ideas?


I am using office 2013.


-----Code as below----

[FONT=Times New Roman][SIZE=3][COLOR=#000000]

[FONT=Calibri]Sub CopyDatafromKYCTemplate()[/FONT]





[FONT=Calibri]    'Declear Variables[/FONT]


[FONT=Calibri]    Dim targetWorkbookAs Workbook, sourceWorkbook As Workbook[/FONT]


[FONT=Calibri]    Dim strDirectoryAs String, fileList As String[/FONT]


[FONT=Calibri]    Dim sheetcount AsInteger[/FONT]


[FONT=Calibri]    Dim lastRow AsLong, lastColumn As Long[/FONT]


[FONT=Calibri]    DimsourceSheetName As String, targetSheetName As String[/FONT]


[FONT=Calibri]    Dim selectCell(1To 50) As String[/FONT]


[FONT=Calibri]    Dim Cell As Range[/FONT]


[FONT=Calibri]    Dim strMsg AsString[/FONT]


[FONT=Calibri]    Dim Scope As Range[/FONT]





[FONT=Calibri]   Application.DisplayAlerts = False[/FONT]


[FONT=Calibri]   Application.AskToUpdateLinks = False[/FONT]


[FONT=Calibri]   Application.ScreenUpdating = False[/FONT]


[FONT=Calibri]   Application.DisplayStatusBar = True[/FONT]





[FONT=Calibri]    'Set positionselected cell[/FONT]


[FONT=Calibri]    Let selectCell(1)= "I3" 'client name[/FONT]


[FONT=Calibri]    Let selectCell(2)= "I4" 'DD[/FONT]


[FONT=Calibri]    Let selectCell(3)= "I5" 'System[/FONT]


[FONT=Calibri]    Let selectCell(4)= "I6" 'System Id[/FONT]


[FONT=Calibri]    Let selectCell(5)= "F14" 'Entity Type[/FONT]


[FONT=Calibri]    Let selectCell(6)= "F15" 'Country of Domicile[/FONT]


[FONT=Calibri]    Let selectCell(7)= "F16" 'Onboarding Location[/FONT]


[FONT=Calibri]    Let selectCell(8)= "F17" 'System Risk Rating[/FONT]


[FONT=Calibri]    Let selectCell(9)= "I8" 'Business Sponsor (ACO) Name & Title[/FONT]


[FONT=Calibri]    Let selectCell(10)= "I9" 'Business Approver (BSM) Name & Title[/FONT]


[FONT=Calibri]    Let selectCell(11)= "I10" 'Business Area[/FONT]


[FONT=Calibri]    Let selectCell(12)= "I11" 'Case Manager[/FONT]


[FONT=Calibri]    Let selectCell(13)= "I13" '2 Eye Analyst[/FONT]


[FONT=Calibri]    Let selectCell(14)= "I14" 'Date Checked by 2 Eye Analyst[/FONT]


[FONT=Calibri]    Let selectCell(15)= "I15" '4 Eye Analyst[/FONT]


[FONT=Calibri]    Let selectCell(16)= "I16" 'Date Checked by 4 Eye Analyst[/FONT]


[FONT=Calibri]    Let selectCell(17)= "I17" 'Type of Review[/FONT]


[FONT=Calibri]    Let selectCell(18)= "N3" 'Identifying & Understanding the Client[/FONT]


[FONT=Calibri]    Let selectCell(19)= "N4" 'Nature of Business & Purpose of Relationship[/FONT]


[FONT=Calibri]    Let selectCell(20)= "N5" 'Source of Funds[/FONT]


[FONT=Calibri]    Let selectCell(21)= "N6" 'Legal Representatives[/FONT]


[FONT=Calibri]    Let selectCell(22)= "N7" 'Ownership[/FONT]


[FONT=Calibri]    Let selectCell(23)= "N8" 'Source of Wealth[/FONT]


[FONT=Calibri]    Let selectCell(24)= "N9" 'Name List Screening[/FONT]


[FONT=Calibri]    Let selectCell(25)= "N10" 'Politically Exposed Persons[/FONT]


[FONT=Calibri]    Let selectCell(26)= "N11" 'Customer Risk Classification[/FONT]


[FONT=Calibri]    Let selectCell(27)= "N12" 'Approvals & Sign-Offs[/FONT]


[FONT=Calibri]    Let selectCell(28)= "N13" 'Localisation Factors[/FONT]


[FONT=Calibri]    Let selectCell(29)= "N14" 'Total[/FONT]


[FONT=Calibri]    Let selectCell(30)= "L8" 'Percent Completed[/FONT]


[FONT=Calibri]    Let selectCell(31)= "L17" 'Initial Outcome Pass Percentage[/FONT]


[FONT=Calibri]    Let selectCell(32)= "L19" 'Final  QC PassPercentage[/FONT]


[FONT=Calibri]    Let selectCell(34)= "L11" 'Data Points Addressed[/FONT]


[FONT=Calibri]    Let selectCell(35)= "L13" 'Number of Initial Outcome "Pass" Data Points[/FONT]


[FONT=Calibri]    Let selectCell(36)= "L15" 'Total Number of Data Points Assessed[/FONT]


[FONT=Calibri]    Let selectCell(37)= "I21" 'QA Analyst Name[/FONT]


[FONT=Calibri]    Let selectCell(38)= "F1" 'Template KOP Version[/FONT]


[FONT=Calibri]    Let selectCell(39)= "O3" 'Identifying & Understanding the Client[/FONT]


[FONT=Calibri]    Let selectCell(40)= "O4" 'Nature of Business & Purpose of Relationship[/FONT]


[FONT=Calibri]    Let selectCell(41)= "O5" 'Source of Funds[/FONT]


[FONT=Calibri]    Let selectCell(42)= "O6" 'Legal Representatives[/FONT]


[FONT=Calibri]    Let selectCell(43)= "O7" 'Ownership[/FONT]


[FONT=Calibri]    Let selectCell(44)= "O8" 'Source of Wealth[/FONT]


[FONT=Calibri]    Let selectCell(45)= "O9" 'Name List Screening[/FONT]


[FONT=Calibri]    Let selectCell(46)= "O10" 'Politically Exposed Persons[/FONT]


[FONT=Calibri]    Let selectCell(47) = "O11" 'CustomerRisk Classification[/FONT]


[FONT=Calibri]    Let selectCell(48)= "O12" 'Approvals & Sign-Offs[/FONT]


[FONT=Calibri]    Let selectCell(49)= "O13" 'Localisation Factors[/FONT]


[FONT=Calibri]    Let selectCell(50)= "O14" 'Total[/FONT]





[FONT=Calibri]    'Browse dialog[/FONT]


[FONT=Calibri]    On Error ResumeNext[/FONT]


[FONT=Calibri]    WithApplication.FileDialog(msoFileDialogFolderPicker)[/FONT]


[FONT=Calibri]        .Title ="Select folder that contains the KYC Templates"[/FONT]


[FONT=Calibri]        If .Show = -1Then[/FONT]


[FONT=Calibri]           strDirectory = .SelectedItems(1)[/FONT]


[FONT=Calibri]        End If[/FONT]


[FONT=Calibri]    End With[/FONT]





[FONT=Calibri]    'If path is notselected[/FONT]


[FONT=Calibri]    If strDirectory = "" Then[/FONT]


[FONT=Calibri]    MsgBox "Nofolder selected"[/FONT]


[FONT=Calibri]    Exit Sub[/FONT]


[FONT=Calibri]    End If[/FONT]





[FONT=Calibri]    'Remove autofilter[/FONT]


[FONT=Calibri]    IfSheets("Macro").AutoFilterMode = True Then[/FONT]


[FONT=Calibri]   Sheets("Macro").AutoFilterMode = False[/FONT]


[FONT=Calibri]    End If[/FONT]





[FONT=Calibri]    'Unprotect Sheet[/FONT]


[FONT=Calibri]   Sheets("Macro").Unprotect "QCMI"[/FONT]





[FONT=Calibri]    'Retrieve currentwork book[/FONT]


[FONT=Calibri]    Set targetWorkbook= ThisWorkbook[/FONT]





[FONT=Calibri]    'Retrieve allfiles[/FONT]


[FONT=Calibri]    fileList =Dir(strDirectory & "\*.xl*")[/FONT]


[FONT=Calibri]    sheetcount = 0[/FONT]





[FONT=Calibri]    Do While fileList<> ""[/FONT]





[FONT=Calibri]       'In case thisexcel file is in the same folder,do not read this file[/FONT]


[FONT=Calibri]       If fileList<> ThisWorkbook.Name Then[/FONT]





[FONT=Calibri]           'Set thelast column[/FONT]


[FONT=Calibri]           lastColumn= 1[/FONT]





[FONT=Calibri]           'Openworkbook[/FONT]


[FONT=Calibri]           SetsourceWorkbook = Workbooks.Open(strDirectory & "\" &fileList)[/FONT]


[FONT=Calibri]          targetWorkbook.Activate[/FONT]





[FONT=Calibri]           'Find lastRow[/FONT]


[FONT=Calibri]           lastRow =targetWorkbook.Sheets("Macro").Cells(Rows.Count,"B").End(xlUp).Row[/FONT]


[FONT=Calibri]          Cells(lastRow + 1, lastColumn).Value = fileList[/FONT]





[FONT=Calibri]           'Copy andreplace value into the target file[/FONT]


[FONT=Calibri]           For i = 1To UBound(selectCell)[/FONT]


[FONT=Calibri]               lastColumn = lastColumn + 1[/FONT]


[FONT=Calibri]               'Linkcell with other Workbook[/FONT]


[FONT=Calibri]              Cells(lastRow + 1, lastColumn).Value = "='[" & fileList& "]Template'!$" & selectCell(i)[/FONT]





[FONT=Calibri]           Next i[/FONT]





[FONT=Calibri]    'Insert Formulafor File Fail/Pass[/FONT]


[FONT=Calibri]    Cells(lastRow + 1,lastColumn - 17).Formula = "=IF(RC[-3]="""",""PercentageCompleted column is blank. Pleaseinvestigate"",IF(RC[-2]="""",""Intialoutcome pass percentage column is blank. PleaseInvestigate"",IF(RC[-1]="""",""Final QCpass percentage column is blank. PleaseInvestigate"",IF(RC[-3]<1,""The file is incomplete.Please investigate"",IF(RC[-1]<1,""The file isincomplete. Pleaseinvestigate"",IF(RC[-2]<1,""Fail"",""Pass""))))))"[/FONT]


[FONT=Calibri]    For Each Cell InRange([AH1], Cells(Rows.Count, "AH").End(xlUp))[/FONT]


[FONT=Calibri]    If Len(Cell.Value)> 0 Then[/FONT]


[FONT=Calibri]    If Cell.Value ="Pass" Then[/FONT]


[FONT=Calibri]   Cell.Interior.Color = RGB(146, 208, 80)[/FONT]


[FONT=Calibri]    Else[/FONT]


[FONT=Calibri]    If Cell.Value ="Fail" Then[/FONT]


[FONT=Calibri]   Cell.Interior.Color = RGB(204, 51, 0)[/FONT]


[FONT=Calibri]    Cell.Font.Bold =True[/FONT]


[FONT=Calibri]    Else[/FONT]


[FONT=Calibri]    If Cell.Value ="The file is incomplete. Please investigate" Then[/FONT]


[FONT=Calibri]    Cell.Font.Color =RGB(255, 0, 0)[/FONT]


[FONT=Calibri]    Else[/FONT]


[FONT=Calibri]    If Cell.Value ="Percentage Completed column is blank. Please investigate" Then[/FONT]


[FONT=Calibri]    Cell.Font.Color =RGB(255, 0, 0)[/FONT]


[FONT=Calibri]    Else[/FONT]


[FONT=Calibri]    If Cell.Value ="Intial outcome pass percentage column is blank. Please Investigate"Then[/FONT]


[FONT=Calibri]    Cell.Font.Color =RGB(255, 0, 0)[/FONT]


[FONT=Calibri]    Else[/FONT]


[FONT=Calibri]    If Cell.Value ="Final QC pass percentage column is blank. Please Investigate" Then[/FONT]


[FONT=Calibri]    Cell.Font.Color =RGB(255, 0, 0)[/FONT]








[FONT=Calibri]            End If[/FONT]


[FONT=Calibri]            End If[/FONT]


[FONT=Calibri]            End If[/FONT]


[FONT=Calibri]            End If[/FONT]


[FONT=Calibri]            End If[/FONT]


[FONT=Calibri]            End If[/FONT]


[FONT=Calibri]            End If[/FONT]





[FONT=Calibri]            Next[/FONT]





[FONT=Calibri]           'Closesource file[/FONT]


[FONT=Calibri]          sourceWorkbook.Close SaveChanges:=False[/FONT]


[FONT=Calibri]           SetsourceWorkbook = Nothing[/FONT]





[FONT=Calibri]           'IncrementSheet[/FONT]


[FONT=Calibri]           sheetcount= sheetcount + 1[/FONT]





[FONT=Calibri]       End If[/FONT]





[FONT=Calibri]      Application.StatusBar = "Macro is running. Please wait. "& sheetcount & " files completed."[/FONT]





[FONT=Calibri]        'Save the file[/FONT]


[FONT=Calibri]      targetWorkbook.Save[/FONT]





[FONT=Calibri]       'Next file[/FONT]


[FONT=Calibri]       fileList = Dir[/FONT]





[FONT=Calibri]    Loop[/FONT]





[FONT=Calibri]    Set Scope =Range("A12", Range("AY" & Rows.Count).End(xlUp))[/FONT]





[FONT=Calibri]    'Sort data on thebasis of date 4 eye check completed[/FONT]


[FONT=Calibri]    Scope.SortKey1:=[Q11], _[/FONT]


[FONT=Calibri]   Order1:=xlAscending, Header:=xlNo[/FONT]





[FONT=Calibri]    'Copy and Pastespecial values[/FONT]


[FONT=Calibri]    Scope.Select[/FONT]


[FONT=Calibri]    Selection.Copy[/FONT]


[FONT=Calibri]   Selection.PasteSpecial Paste:=xlPasteValues[/FONT]





[FONT=Calibri]    'Insert Borders[/FONT]


[FONT=Calibri]    With Scope.Borders[/FONT]


[FONT=Calibri]    .LineStyle =xlContinuous[/FONT]


[FONT=Calibri]    .Weight = xlThin[/FONT]


[FONT=Calibri]    .ColorIndex = 1[/FONT]


[FONT=Calibri]     End With[/FONT]





[FONT=Calibri]     'InsertAutofilter[/FONT]


[FONT=Calibri]     If NotSheets("Macro").AutoFilterMode Then[/FONT]


[FONT=Calibri]    Sheets("Macro").Range("A11:AY11").AutoFilter[/FONT]


[FONT=Calibri]     End If[/FONT]





[FONT=Calibri]    'Selecting aparticular cell[/FONT]


[FONT=Calibri]   Range("A12").Select[/FONT]


[FONT=Calibri]   Application.CutCopyMode = False[/FONT]





[FONT=Calibri]    'Identifyduplicate clients on System id basis[/FONT]


[FONT=Calibri]    For Each Cell InRange([E1], Cells(Rows.Count, "E").End(xlUp))[/FONT]


[FONT=Calibri]        IfLen(Cell.Value) > 0 Then[/FONT]


[FONT=Calibri]        IfWorksheetFunction.CountIf(Range([E1], Cells(Rows.Count,"E").End(xlUp)), Cell) > 1 Then[/FONT]


[FONT=Calibri]       Cell.Interior.ColorIndex = 3[/FONT]


[FONT=Calibri]        strMsg ="There are duplicate clients highlighted in red under System Id column,please check and re-run the macro"[/FONT]


[FONT=Calibri]        Else[/FONT]


[FONT=Calibri]            End If[/FONT]


[FONT=Calibri]            End If[/FONT]





[FONT=Calibri]    Next[/FONT]


[FONT=Calibri]    If Len(strMsg)> 0 Then MsgBox strMsg[/FONT]





[FONT=Calibri]    'Identifyincomplete files[/FONT]


[FONT=Calibri]    For Each Cell InRange([AE1], Cells(Rows.Count, "AE").End(xlUp))[/FONT]


[FONT=Calibri]        IfLen(Cell.Value) > 0 Then[/FONT]


[FONT=Calibri]        If Cell.Value< 1 Then[/FONT]


[FONT=Calibri]   Cell.Interior.ColorIndex = 3[/FONT]


[FONT=Calibri]    strMsg ="There are incomplete files, please refer to Percent Completed column.Please check and re-run the macro"[/FONT]


[FONT=Calibri]        Else[/FONT]





[FONT=Calibri]            End If[/FONT]


[FONT=Calibri]            End If[/FONT]








[FONT=Calibri]    Next[/FONT]


[FONT=Calibri]    If Len(strMsg)> 0 Then MsgBox strMsg[/FONT]





[FONT=Calibri]    For Each Cell InRange([AG1], Cells(Rows.Count, "AG").End(xlUp))[/FONT]


[FONT=Calibri]        IfLen(Cell.Value) > 0 Then[/FONT]


[FONT=Calibri]        If Cell.Value< 1 Then[/FONT]


[FONT=Calibri]   Cell.Interior.ColorIndex = 3[/FONT]


[FONT=Calibri]    strMsg ="There are incomplete files, please refer to Final QC Pass Percentagecolumn. Please check and re-run the macro"[/FONT]


[FONT=Calibri]    Else[/FONT]








[FONT=Calibri]            End If[/FONT]


[FONT=Calibri]            End If[/FONT]





[FONT=Calibri]    Next[/FONT]


[FONT=Calibri]    If Len(strMsg)> 0 Then MsgBox strMsg[/FONT]





[FONT=Calibri]    'Protect Sheet[/FONT]


[FONT=Calibri]   Sheets("Macro").Protect "QCMI", AllowFiltering:=True[/FONT]





[FONT=Calibri]    'Save the file[/FONT]


[FONT=Calibri]   targetWorkbook.Save[/FONT]





[FONT=Calibri]    MsgBox ("Datafrom " & sheetcount & " KYC Templates have been pasted")[/FONT]





[FONT=Calibri]Application.DisplayAlerts = True[/FONT]


[FONT=Calibri]Application.AskToUpdateLinks = True[/FONT]


[FONT=Calibri]Application.ScreenUpdating = True[/FONT]


[FONT=Calibri]Application.StatusBar = False[/FONT]








[FONT=Calibri] End Sub[/FONT]


[/COLOR][/SIZE][/FONT]

 

[baitmaster]

Using DIR whilst running through files and changing them can be unpredictable. I would suggest that you use DIR to create the list of all files first, and then run through that list to perform your requested actions. If it fails then you can also inspect that list to see why it stopped where it did

 

[vaibhavagar]

Thanks buddy for the response and suggestion. I am new to VBA so please help with the actual code that what should I change the existing one to.

 

[baitmaster]

I had some trouble with the code because it wasn't added to the website using code tags and so it became a bit corrupted. Lots of words got joined together, stuff like that. I've had a quick play to come up with the following, note that once I did the important bits I cut the rest of it off so it's incomplete. Also, I haven't tested it so I have no idea if it will work or not. I suspect the following is something near what you want, basically I created an array of file name strings using DIR, then I loop through the array. I also took the liberty of introducing you to SELECT rather than a whole heap of IF statements

Option Explicit

Sub CopyDatafromKYCTemplate()


'Declear Variables
Dim targetWorkbook As Workbook, sourceWorkbook As Workbook
Dim strDirectory As String, fileList As String
Dim sheetcount As Integer
Dim lastRow As Long, lastColumn As Long
Dim sourceSheetName As String, targetSheetName As String


Dim selectCell(1 To 50) As String


Dim Cell As Range
Dim strMsg As String
Dim Scope As Range


Application.DisplayAlerts = False
Application.AskToUpdateLinks = False
Application.ScreenUpdating = False
Application.DisplayStatusBar = True


'Set positionselected cell
Let selectCell(1) = "I3" 'client name
Let selectCell(2) = "I4" 'DD
Let selectCell(3) = "I5" 'System
Let selectCell(4) = "I6" 'System Id
Let selectCell(5) = "F14" 'Entity Type
Let selectCell(6) = "F15" 'Country of Domicile
Let selectCell(7) = "F16" 'Onboarding Location
Let selectCell(8) = "F17" 'System Risk Rating
Let selectCell(9) = "I8" 'Business Sponsor (ACO) Name & Title
Let selectCell(10) = "I9" 'Business Approver (BSM) Name & Title
Let selectCell(11) = "I10" 'Business Area
Let selectCell(12) = "I11" 'Case Manager
Let selectCell(13) = "I13" '2 Eye Analyst
Let selectCell(14) = "I14" 'Date Checked by 2 Eye Analyst
Let selectCell(15) = "I15" '4 Eye Analyst
Let selectCell(16) = "I16" 'Date Checked by 4 Eye Analyst
Let selectCell(17) = "I17" 'Type of Review
Let selectCell(18) = "N3" 'Identifying & Understanding the Client
Let selectCell(19) = "N4" 'Nature of Business & Purpose of Relationship
Let selectCell(20) = "N5" 'Source of Funds
Let selectCell(21) = "N6" 'Legal Representatives
Let selectCell(22) = "N7" 'Ownership
Let selectCell(23) = "N8" 'Source of Wealth
Let selectCell(24) = "N9" 'Name List Screening
Let selectCell(25) = "N10" 'Politically Exposed Persons
Let selectCell(26) = "N11" 'Customer Risk Classification
Let selectCell(27) = "N12" 'Approvals & Sign-Offs
Let selectCell(28) = "N13" 'Localisation Factors
Let selectCell(29) = "N14" 'Total
Let selectCell(30) = "L8" 'Percent Completed
Let selectCell(31) = "L17" 'Initial Outcome Pass Percentage
Let selectCell(32) = "L19" 'Final  QC PassPercentage
Let selectCell(34) = "L11" 'Data Points Addressed
Let selectCell(35) = "L13" 'Number of Initial Outcome "Pass" Data Points
Let selectCell(36) = "L15" 'Total Number of Data Points Assessed
Let selectCell(37) = "I21" 'QA Analyst Name
Let selectCell(38) = "F1" 'Template KOP Version
Let selectCell(39) = "O3" 'Identifying & Understanding the Client
Let selectCell(40) = "O4" 'Nature of Business & Purpose of Relationship
Let selectCell(41) = "O5" 'Source of Funds
Let selectCell(42) = "O6" 'Legal Representatives
Let selectCell(43) = "O7" 'Ownership
Let selectCell(44) = "O8" 'Source of Wealth
Let selectCell(45) = "O9" 'Name List Screening
Let selectCell(46) = "O10" 'Politically Exposed Persons
Let selectCell(47) = "O11" 'CustomerRisk Classification
Let selectCell(48) = "O12" 'Approvals & Sign-Offs
Let selectCell(49) = "O13" 'Localisation Factors
Let selectCell(50) = "O14" 'Total


'Browse dialog
On Error Resume Next
WithApplication.FileDialog (msoFileDialogFolderPicker)
    .Title = "Select folder that contains the KYC Templates"
    If .Show = -1 Then
       strDirectory = .SelectedItems(1)
    End If
End With


'If path is not selected
If strDirectory = "" Then
    MsgBox "Nofolder selected"
    Exit Sub
End If




'Remove autofilter
If Sheets("Macro").AutoFilterMode = True Then Sheets("Macro").AutoFilterMode = False


'Unprotect Sheet
Sheets("Macro").Unprotect "QCMI"
 
'Retrieve currentwork book
Set targetWorkbook = ThisWorkbook


Dim arrFileList()
Dim iFileCount As Integer


' create array of filenames
fileList = Dir(strDirectory & "\*.xl*")


Do While fileList <> ""
    iFileCount = iFileCount + 1
    ReDim Preserve arrFileList(1 To iFileCount)
    arrFileList(iFileCount) = fileList
    fileList = Dir
Loop




' loop through list of file names
Dim i As Integer
For i = LBound(arrFileList) To UBound(arrFileList)


sheetcount = 0
    
    'In case this excel file is in the same folder,do not read this file
    If arrFileList(i) = ThisWorkbook.Name Then GoTo nextI
    
    'Set the last column
    lastColumn = 1
    
    'Open workbook
    Set sourceWorkbook = Workbooks.Open(strDirectory & "\" & arrFileList(i))
    targetWorkbook.Activate
    
    'Find lastRow
    lastRow = targetWorkbook.Sheets("Macro").Cells(Rows.Count, "B").End(xlUp).Row
    Cells(lastRow + 1, lastColumn).Value = arrFileList(i)


    'Copy and replace value into the target file
    For i = 1 To UBound(selectCell)
        
        lastColumn = lastColumn + 1
        
        'Link cell with other Workbook
        Cells(lastRow + 1, lastColumn).Value = "='[" & arrFileList(i) & "]Template'!$" & selectCell(i)
        
    Next i


    'Insert Formula for File Fail/Pass
    Cells(lastRow + 1, lastColumn - 17).Formula = "=IF(RC[-3]="""",""Percentage Completed column is blank. Please investigate"",IF(RC[-2]="""",""Intial outcome pass percentage column is blank. Please Investigate"",IF(RC[-1]="""",""Final QC pass percentage column is blank. PleaseInvestigate"",IF(RC[-3]<1,""The file is incomplete.Please investigate"",IF(RC[-1]<1,""The file isincomplete. Pleaseinvestigate"",IF(RC[-2]<1,""Fail"",""Pass""))))))"




    For Each Cell In Range([AH1], Cells(Rows.Count, "AH").End(xlUp))




        If Len(Cell.Value) > 0 Then
            
            Select Case Cell.Value
                Case "Pass": Cell.Interior.Color = RGB(146, 208, 80)
                Case "Fail": Cell.Interior.Color = RGB(204, 51, 0): Cell.Font.Bold = True
                Case "The file is incomplete. Please investigate": Cell.Font.Color = RGB(255, 0, 0)
                Case "Percentage Completed column is blank. Please investigate": Cell.Font.Color = RGB(255, 0, 0)
                Case "Intial outcome pass percentage column is blank. Please Investigate": Cell.Font.Color = RGB(255, 0, 0) ' note there is a Typo in this test
                Case "Final QC pass percentage column is blank. Please Investigate": Cell.Font.Color = RGB(255, 0, 0)
            End Select
        
        End If
    Next Cell


    'Close source file
    sourceWorkbook.Close SaveChanges:=False
    SetsourceWorkbook = Nothing
    
    'IncrementSheet
    sheetcount = sheetcount + 1
    
    Application.StatusBar = "Macro is running. Please wait. " & sheetcount & " files completed."


    'Save the file
    targetWorkbook.Save
    
'Next file
nextI:
Next i


 End Sub

 

[baitmaster]

You should also include Case Else for when none of your conditions is met, so you could add another Case to the Select Statement as a catch-all, for example:

Case Else: MsgBox "no value identified, break here for more details"

 

[Fluff]

Cross posted https://www.excelforum.com/excel-pr...031-vba-loop-getting-break-automatically.html

While we do not prohibit Cross-Posting on this site, we do ask that you please mention you are doing so and provide links in each of the threads pointing to the other thread (see rule 13 here along with the explanation: Forum Rules).
This way, other members can see what has already been done in regards to a question, and do not waste time working on a question that may already be answered.

 

[vaibhavagar]

Thanks for the code and details. This is very helpful.
However getting an error message (after fixing joined stuff issue) as "Compile Error: For Control variable already in use" for code "For i=1 To UBound(selectcell)"

Please help at earliest. We are almost there.

 

[baitmaster]

OK didn't notice that

for i = ...

has been written within another such loop, so the "i" is being used already. Try swapping to a new variable e.g. "j"