如果主工作簿与主工作簿匹配，则查找并循环工作簿并复制值

Question

我想自动化一个过程，该过程需要我查找最多 20 个工作簿并在另一个单元格与主工作簿匹配时复制一个单元格。我想创建类似于 Excel 的内置查找功能的东西，但必须处理和循环多个工作簿。我上传了一张屏幕截图，显示了主工作簿中的 sheet（“基础”）的样子，以及我复制单元格值的 sheets（“报告”）之一的示例从。包含报告 sheet 的工作簿（每个工作簿一个 sheet）存储在本地文件夹中。

到目前为止，我一直试图通过从一个“报告工作簿”开始然后尝试将值复制到主工作簿来保持简单。这就是我想要的逻辑：如果报告 sheet 中的单元格 B10（以红色突出显示）与范围 I4:I19 中的单元格之一（以绿色突出显示）匹配，则应将单元格 F13 中的值复制到索引列（以黄色突出显示）中，否则不要执行任何操作。对文件夹中的每个工作簿循环并重复该过程。

在此特定情况下，匹配“200S”，这意味着应将单元格 F13 中的值 105 复制到单元格 L18 中。（注意，多个路由可以在同一个单元格中，用逗号分隔（就像这里一样）。

到目前为止，这是我的代码，它可以工作，但我希望它循环访问固定文件夹中的多个工作簿：

Sub CopyLookup()
    Dim rng1 As Range, c1 As Range, rng2 As Range, c2 As Range
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lnLastRow1 As Long, lnLastRow2 As Long
    
     'Create an object for each worksheet:
    Set ws1 = Worksheets("Report")
    Set ws2 = Worksheets("Basis")
    
     'Get the row number of the last cell containing data in the basis sheet:
    lnLastRow2 = ws2.Cells(ws2.Cells.Rows.Count, "A").End(xlUp).Row
    
     'Create range objects for the two columns to be compared:
    Set rng1 = ws1.Range("B10")
    Set rng2 = ws2.Range("I4:I19")
    
     'Loop through each cell in col I in sheet 2:
    For Each c2 In rng2
        
         'Check if the cell is not blank:
        If c2.Value <> "" Then
        
             'Loop through each cell in cell B10 in other sheet:
            For Each c1 In rng1
                
                 'Test if cells match:
                If c1.Value = c2.Value Then
                    
                     'Copy value from sheet 1 to sheet 2 (main workbook):
                    c2.Offset(0, 3).Value = c1.Offset(3, 4).Value
                    
                     'Move on to next cell in sheet 2:
                    Exit For '(exits the "For Each c1 In rng1" loop)
                    
                End If
            Next c1
        End If
    Next c2
End Sub

必须修改代码以处理单独的工作簿（而不是目前完成的一个工作簿）并遍历文件夹中的多个工作簿，并将它们与复制值的主工作簿进行比较。

Answer 1

我只是举例说明如何遍历报表文件。

此代码应在基础工作簿中。它循环遍历 RootFolder 并在文件变量中添加与 Report.xslx 文件模式匹配的所有文件。根据需要修改它。

Dim File As Variant
Dim fileList As Collection
Dim RootFolder As String

Set fileList = New Collection

'Path of Folder to search for Reportfiles
RootFolder = "C:\Example\Path\"

'Modify *Report*.xlsx to match your Report File Names
File = Dir(RootFolder & "*Report*.xlsx")

'Loop Through all Report files
While File <> ""

    'Add File to Collection
    fileList.Add RootFolder & File
    File = Dir
Wend

Dim FilePath As Variant

Dim objBasis As Workbook
Dim objReport As Workbook

'Set BasisFile
Set objBasis = ThisWorkbook

'Loop Through Report Files
For Each FilePath In fileList

    'Open Workbook
    Set objReport = Workbooks.Open(FilePath)

    '#######################################################
    'PASTE YOUR CODE HERE

    'Example To access Values from Sheet in ReportFile
    Debug.Print objReport.Sheets("Report").Cells(1, 1).Value
    '#######################################################

    'Close ReportFile without saving
    objReport.Close False
Next FilePath

如果主工作簿与主工作簿匹配，则查找并循环工作簿并复制值

Lookup from and loop through workbooks and copy value if there is a match to main workbook to main workbook

lookup

vba

copy-paste

string-matching