執行 While 循環以打開多個工作簿、執行列比較宏、然后關閉工作簿並另存為新文件

Question

我需要一些幫助才能使循環正常工作。 根據我的代碼，我想做以下事情：

1. 從文檔路徑列表中打開一系列工作簿示例：

2. 將“ThisWorkbook”中的 B 列與已打開的工作簿進行比較。

3. 如果找到比較，則突出顯示單元格綠色並將“ThisWorkbook”行的 rest 粘貼到打開的工作簿中。
4. 將每個工作簿另存為新名稱（此代碼部分已完成並且運行良好）

我的問題是它打開了我列表中的每個文檔，但是當打開大量文檔時比較（適用於打開的單個文檔）未對齊，然后在我使用“ActiveWorkbooks”時保存文檔也存在問題。

我認為問題是在哪里執行循環 - 很可能是我需要做一個 for 或 while 循環？

注意：該代碼對於每個步驟 1-4 都可以完美運行，但是將它們組合在一起並且對於多個工作簿，它並不能滿足我的需要。

主要工作簿 (Thisworkbook) Sheet1 的照片：

比較前打開的工作簿示例：

保存后打開工作簿的示例和預期的 output 結果：

然而，循環搞亂了比較，並為第二個打開的工作簿給出了這樣的結果：

任何解決此循環的幫助將不勝感激！

   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

更新的代碼嘗試：根據評論：

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

我覺得我需要使 varsheet2 成為 t 的 function。 我已經證明，當打開多個工作表（在打開的工作簿中）時，顏色以及復制和粘貼會被從列表中打開的第一個工作簿中的行數抵消。 我嘗試使用 varsheet.cells(k,2) 作為參考，但這並沒有解決問題。

Answer 1

將 k 值放在 Do While 循環中可以解決問題。

'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