执行 While 循环以打开许多工作簿，执行列比较宏，然后关闭工作簿并另存为新文件答案

【问题标题】：Do While Loop for opening many workbooks, performing a column comparison macro, then closing workbooks and saving as a new file执行 While 循环以打开许多工作簿，执行列比较宏，然后关闭工作簿并另存为新文件
【发布时间】：2020-01-27 00:34:11
【问题描述】：

我需要一些帮助才能使循环正常工作。根据我的代码，我想做以下事情：

从文档路径列表中打开一系列工作簿例子：
将“ThisWorkbook”中的 B 列与已打开的工作簿进行比较。
如果找到比较，它将突出显示单元格绿色并将“ThisWorkbook”中的行的其余部分粘贴到打开的工作簿中。
为每个工作簿另存为新名称（此代码部分已完成并且运行良好）

我的问题是它打开了我列表中的每个文档，但是当打开大量文档时，比较（适用于打开的单个文档）未对齐，然后在我使用时保存文档也存在问题“活动工作簿”。

我认为问题在于在哪里执行循环 - 很可能是我需要执行 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

更新的代码尝试：根据 cmets：

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 的函数。我已经证明，当打开多个工作表（在打开的工作簿中）时，颜色以及复制和粘贴会被从列表中打开的第一个工作簿中的行数抵消。我尝试使用 varsheet.cells(k,2) 作为参考，但这并没有解决问题。

【问题讨论】：

使用ActiveWorkbook 可能会导致问题。第一步 - 将工作簿变量分配给Workbooks.Open 的结果：Dim wb As Workbook，然后是Set wb = Application.Workbooks.Open(sFullName, False)。现在您有了一个工作簿参考，可以用来限定未来的行。
嗨@BigBen 感谢您的回复！值得注意的一点，但仍然不确定为什么当多个文档添加到列表中时，它会抵消第二个文档的比较结果（如颜色所示）。我认为它可能只是引用了错误的文件？我是否也应该提到“ThisWorkbook”，因为我没有在我的代码中这样做，但觉得没有必要调出“主工作簿”。
最佳实践是完全限定Workbook 和Worksheet，即Cells(k, 2) 是有问题的，因为有一个隐含的ActiveSheet 和ActiveWorkbook。您可以参考主工作簿中的工作表或 ThisWorkbook 的代码名称来简化。
谢谢！我会试试看结果如何。
嗨，我尝试通过限定工作簿进行修复，但不断收到错误 Method 'SaveAs' of object'_Workbook' failed。为什么会这样？我想做的就是打开一个工作簿，与那个工作簿进行比较，用新名称保存工作簿，然后将其关闭，然后打开下一个并重复。它似乎不会在使用后关闭工作簿，这可能会解决问题并且不会引起混乱。

标签： excel vba

【解决方案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

【讨论】：