Question

我想自动化一个过程，这个过程要求我查找多达20个工作簿，并在另一个单元格与主工作簿匹配时复制单元格。我想创建类似于Excel的内置查找功能，但必须处理并遍历多个工作簿。我上传了一个屏幕截图，其中显示了主工作簿中的工作表（＆＃34; Basis＆＃34;）是如何显示的，以及我复制的其中一个工作表（＆＃34; Report＆＃34;）的示例来自的细胞价值。包含报告表的工作簿（每个工作簿一张）存储在本地文件夹中。

到目前为止，我已经尝试通过一个＆＃34;报告工作簿＆＃34;然后尝试将值复制到主工作簿。这就是我想要的逻辑：如果报告表中的单元格B10（以红色突出显示）与范围I4中的一个单元格之间存在匹配：I19（以绿色突出显示），则单元格F13中的值应该是被复制到索引列（以黄色突出显示），否则不要做任何事情。循环并重复该过程与文件夹中的每个工作簿。

在这种特殊情况下，＆＃34; 200S＆＃34;匹配，这意味着单元格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

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

我输了。非常感谢任何帮助。 THX

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

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

1 个答案: