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

Posted 2023-02-22

【中文标题】如果主工作簿与主工作簿匹配，则从工作簿中查找和循环并复制值

【英文标题】：Lookup from and loop through workbooks and copy value if there is a match to main workbook to main workbook

【发布时间】：2016-06-22 01:30:42

【问题描述】：

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

到目前为止，我已尝试从一个“报告工作簿”开始，然后尝试将值复制到主工作簿，以保持简单。这就是我想要的逻辑：如果报告表中的单元格 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

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

【参考方案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