Do While Loop for opening many workbooks, performing a column comparison macro, then closing workbooks and saving as a new file

Question

I need some help getting a loop to work. As per my code I want to do the following:

Open up a range of workbooks from a list of document paths Example:
Compare column B in "ThisWorkbook" to the workbooks which have been opened.
If it finds a comparison, it highlights the cell green and pastes the rest of the row from "ThisWorkbook" to the opened workbooks.
SaveAs each workbook with a new name (this code section has been completed and works well)

My issue is that it opens up every document in my list, but the comparison (which works for a single document opened) misaligns when lots of documents are opened, and then there are also issues with saving the documents as I use "ActiveWorkbooks".

I think the problem is where to perform the loop - It could well be that I need to do a for or while loop?

Note: The code works perfectly for each step 1-4 individually, but combining it together and for more than one workbook it doesn't do what I need it to do.

Photo of the main workbook (Thisworkbook) Sheet1:

Example of open workbook before comparison:

Example of open workbook after saving and expected output result:

The loop however messes up the comparison and gives a result like this for a second open workbook:

Any help to fix this loop would be greatly appreciated!

   Sub OverallProcess()
   Dim sheet1 As Worksheet, Sheet2 As Worksheet, wbkA As Workbook, wbkB As Workbook, wbkAColB As 
   Variant, wbkBColB As Variant
   Dim i As Long, j As Long, k As Long: k = 2
Dim isFound As Boolean: isFound = False

Application.ScreenUpdating = False

'read column in master document
Set sheet1 = Sheets(1)
Set Sheet2 = Sheets(2)
Sheet1ColB = sheet1.Range("B2:D" & sheet1.Cells(sheet1.Rows.Count, 2).End(xlUp).Row).Value2

'Open up next linked workbook from list and read column
 Dim sFullName As String
 Dim t      As Integer
 Dim wsh As Worksheet

'On Error GoTo Err_openFiles

Set wsh = ThisWorkbook.Worksheets("Sheet2")
t = 1
Do While wsh.Range("A" & t) <> ""
sFullName = wsh.Range("A" & t)
Application.Workbooks.Open sFullName, UpdateLinks:=False
't = t + 1
'Loop
'Exit_openFiles:
'On Error Resume Next
'Set wsh = Nothing
'Exit Sub

'Err_openFiles:
'MsgBox Err.Description, vbExclamation, Err.Number
'Resume Exit_openFiles

'Read column in open linked document
Set varsheet2 = ActiveWorkbook.Worksheets("Sheet1")
wbkBColB = varsheet2.Range("B2:B" & varsheet2.Cells(varsheet2.Rows.Count, 2).End(xlUp).Row).Value2


 'Loop through part numbers to find matches and non-matches 
   For i = LBound(wbkBColB) To UBound(wbkBColB)
    isFound = False
    For j = LBound(Sheet1ColB) To UBound(Sheet1ColB)
        'perform case insensitive (partial) comparison
        If InStr(1, LCase(wbkBColB(i, 1)), LCase(Sheet1ColB(j, 1))) > 0 Then

        'If it finds a match, it highlights cell green
        Cells(k, 2).Interior.ColorIndex = 4

   'Numbers below in brackets are the columns Note: The 'j' numbers are 1 below the k numbers
    'k numbers ColA =1, ColB =2, ColC=3 etc
        'j numbers, ColB = 1, ColC =2, ColD=3 etc

            varsheet2.Cells(k, 3) = Sheet1ColB(j, 2)
            varsheet2.Cells(k, 4) = Sheet1ColB(j, 3)
            k = k + 1
            isFound = True

        End If

    Next

    If Not isFound Then

    'If it doesn't find a match, it highlights the cell yellow
        Cells(k, 2).Interior.ColorIndex = 6
        k = k + 1
    End If
Next


  'Saving the files into a new folder with an uprevved name
Dim filepath As String
Dim filename As String
Dim filepatharch As String
Dim filelist As String
Dim filedate As String
Dim filecount As Integer

    'Set where to save and the file naming convention
    filepath = "H:\BoM Drafts Macro\"
    filename = ActiveWorkbook.Name

    Str1 = Left(filename, InStr(filename, ".") - 1)

    Title = Right(Str1, Len(Str1) - InStr(Str1, " "))

    LastNum = Right(Left(Str1, Len(Str1) - Len(Title) - 1), Len(Str1) - Len(Title) - 14)

    ShortName = Left(Str1, 13)

    If InStr(filename, ".") > 0 Then
    Str1 = Left(filename, InStr(filename, ".") - 1)
    Title = Right(Str1, Len(Str1) - InStr(Str1, " "))
    LastNum = Right(Left(Str1, Len(Str1) - Len(Title) - 1), Len(Str1) - Len(Title) - 14)
    ShortName = Left(Str1, 13)
    End If

    LastNum = CStr(CInt(LastNum) + 1)
    Sheets("Sheet1").Copy

    ActiveWorkbook.SaveAs filename:= _
    filepath & ShortName & LastNum & " " & Title & ".xlsx"

    ActiveWindow.Close

    t = t + 1
    Loop

    MsgBox t & "files opened", vbInformation
    End Sub

Updated Code Attempt: As per comments:

Sub OverallProcess()
Dim sheet1 As Worksheet, Sheet2 As Worksheet, wbkA As Workbook, wbkB As Workbook, wbkAColB As Variant, wbkBColB As Variant
Dim i As Long, j As Long, k As Long: k = 2
    Dim isFound As Boolean: isFound = False

    Application.ScreenUpdating = False

    'read column in master document
    Set sheet1 = Sheets(1)
    Set Sheet2 = Sheets(2)
    Sheet1ColB = ThisWorkbook.Sheets(1).Range("B2:D" & ThisWorkbook.Sheets(1).Cells(ThisWorkbook.Sheets(1).Rows.Count, 2).End(xlUp).Row).Value2

'Open up next linked workbook from list and read column
Dim sFullName As String
Dim t      As Integer
Dim wsh As Worksheet
Dim wb As Workbook

Set wsh = ThisWorkbook.Worksheets("Sheet2")
t = 1
Do While wsh.Range("A" & t) <> ""
    sFullName = wsh.Range("A" & t)
    Set wb = Application.Workbooks.Open(sFullName, False)

't = t + 1
'Loop

    'Read column in open linked document
    'Set varsheet2 = ActiveWorkbook.Worksheets("Sheet1")
    Set varsheet2 = wb.Worksheets("Sheet1")
    wbkBColB = varsheet2.Range("B2:B" & varsheet2.Cells(varsheet2.Rows.Count, 2).End(xlUp).Row).Value2

'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

'Loop through part numbers to find matches and non-matches and fill revision/engineering rev accordingly

For i = LBound(wbkBColB) To UBound(wbkBColB)
        isFound = False
        For j = LBound(Sheet1ColB) To UBound(Sheet1ColB)
            'perform case insensitive (partial) comparison
            If InStr(1, LCase(wbkBColB(i, 1)), LCase(Sheet1ColB(j, 1))) > 0 Then

            'If it finds a match, it highlights cell green
            varsheet2.Cells(k, 2).Interior.ColorIndex = 4

    'Numbers below in brackets are the columns Note: The 'j' numbers are 1 below the k numbers
        'k numbers ColA =1, ColB =2, ColC=3 etc
            'j numbers, ColB = 1, ColC =2, ColD=3 etc

                varsheet2.Cells(k, 3) = Sheet1ColB(j, 2)
                varsheet2.Cells(k, 4) = Sheet1ColB(j, 3)

                k = k + 1
                isFound = True

            End If

        Next

        If Not isFound Then

        'If it doesn't find a match, it highlights the cell yellow
            varsheet2.Cells(k, 2).Interior.ColorIndex = 6
            k = k + 1
        End If
    Next

't = t + 1

'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------

'Saving the files into a new folder with an uprevved name
Dim filepath As String
Dim filename As String
Dim filepatharch As String
Dim filelist As String
Dim filedate As String
Dim filecount As Integer

        'Set where to save and the file naming convention
        filepath = "H:\BoM Drafts Macro\"
        'filename = ActiveWorkbook.Name
        filename = wb.Name

        Str1 = Left(filename, InStr(filename, ".") - 1)

        Title = Right(Str1, Len(Str1) - InStr(Str1, " "))

        LastNum = Right(Left(Str1, Len(Str1) - Len(Title) - 1), Len(Str1) - Len(Title) - 14)

        ShortName = Left(Str1, 13)

        If InStr(filename, ".") > 0 Then
        Str1 = Left(filename, InStr(filename, ".") - 1)
        Title = Right(Str1, Len(Str1) - InStr(Str1, " "))
        LastNum = Right(Left(Str1, Len(Str1) - Len(Title) - 1), Len(Str1) - Len(Title) - 14)
        ShortName = Left(Str1, 13)
        End If

        LastNum = CStr(CInt(LastNum) + 1)

        wb.SaveAs filename:= _
        filepath & ShortName & LastNum & " " & Title & ".xlsx"

        'ActiveWindow.Close
        wb.Close

t = t + 1
Loop
MsgBox t & "files opened", vbInformation
End Sub

I feel like I need to make varsheet2 a function of t. I have proven that when more than one sheet (within open workbooks) is opened, that the colours and copy and paste are offset by the number of rows in the first workbook that is opened from the list. I tried using varsheet.cells(k,2) as the ref but this didn't fix the problem.

Working with ActiveWorkbook can cause issues. First step - assign a workbook variable to the result of Workbooks.Open: Dim wb As Workbook, then Set wb = Application.Workbooks.Open(sFullName, False). Now you have a workbook reference with which to qualify future lines. — BigBen
Hi @BigBen thanks for the reply! Good point to note, but still unsure as to why when more than one document is added to the list does it offset the second document result for the comparison (as shown by the colours). I assume it is just references the wrong files perhaps? Should I also be referring to "ThisWorkbook" as I don't do that in my code, but didn't feel the need to call out the "master workbook". — vbAmateur
Best practice is to fully qualify the Workbook and Worksheet, i.e. Cells(k, 2) is problematic because there's an implicit ActiveSheet and ActiveWorkbook. You can refer to the sheets in the master workbook or ThisWorkbook by their code name to simplify. — BigBen
Hi, I tried to fix with qualifying the Workbook but keep getting the error Method 'SaveAs' of object'_Workbook' failed. Any suggestions for why this is? All I would like it to do is open up a workbook, do the comparison with that one workbook, save the workbook with a new name then close it down, then open up the next and repeat. It doesn't seem to close the workbooks after use which may fix the problem and not cause confusion. — vbAmateur

vbAmateur vbAmateur · Accepted Answer · 2019-10-03T10:27:26

Putting the k value within the Do While loop solves the problem.

'Loop through part numbers to find matches and non-matches and fill 
revision/engineering rev accordingly
k = 2
For i = LBound(wbkBColB) To UBound(wbkBColB)
    isFound = False
    For j = LBound(Sheet1ColB) To UBound(Sheet1ColB)
        'perform case insensitive (partial) comparison
        If InStr(1, LCase(wbkBColB(i, 1)), LCase(Sheet1ColB(j, 1))) > 0 Then

        'If it finds a match, it highlights cell green
        Cells(k, 2).Interior.ColorIndex = 4

'Numbers below in brackets are the columns Note: The 'j' numbers are 1 below the k numbers
    'k numbers ColA =1, ColB =2, ColC=3 etc
        'j numbers, ColB = 1, ColC =2, ColD=3 etc

            Cells(k, 3) = Sheet1ColB(j, 2)
            Cells(k, 4) = Sheet1ColB(j, 3)

            k = k + 1
            isFound = True

        End If

    Next

    If Not isFound Then

    'If it doesn't find a match, it highlights the cell yellow
        Cells(k, 2).Interior.ColorIndex = 6
        k = k + 1
    End If
Next

Do While Loop for opening many workbooks, performing a column comparison macro, then closing workbooks and saving as a new file

1 Answers