Выполните пока цикл для открытия многих книг, выполнения макроса сравнения столбцов, затем закрытия книг и сохранения в виде нового файла.

Question

Мне нужна помощь, чтобы заставить цикл работать.В соответствии с моим кодом я хочу сделать следующее:

1. Открыть диапазон рабочих книг из списка путей к документам Пример:

2. Сравните столбец B в "ThisWorkbook" с открытыми рабочими книгами.

3. Если он находит сравнение, он выделяет зеленую ячейку и вставляет оставшуюся часть строки из «ThisWorkbook» в открытые книги.
4. Сохранить как каждую книгу с новым именем (этот раздел кода был завершен и работает хорошо)

Моя проблема в том, что он открывает каждый документ в моем списке, но сравнение (который работает для одного открытого документа) смещается при открытии большого количества документов, а также возникают проблемы с сохранением документов, когда я использую «ActiveWorkbooks».

Я думаю, проблема в том, где выполнить цикл. Может быть, мне нужно сделать цикл for или while?

Примечание. Код отлично работает для каждого шага 1-4 в отдельности, но, объединяя его вместе и для нескольких рабочих книг, он не выполняет то, что мне нужно.

Фотография основной рабочей книги (Thisworkbook) Sheet1:

Пример открытой рабочей книги перед сравнением:

Пример открытой рабочей книги после сохранения и ожидаемого результата вывода:

Цикл, однако, портит сравнение и дает такой результат для второго открытияРабочая тетрадь:

Любая помощь по исправлению этого цикла будет принята с благодарностью!

   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