Excel VBA宏以匹配根文件夹中工作簿的单元格值，然后复制特定单元格

Question

上面的图片是主工作簿。任何人都可以帮我写vba，这样它就会在整个根文件夹（例如C：\ Work \ 2017）中找到与帐号匹配的工作簿，并将B9和E9单元格复制到主单元格。第二张图片是系统生成的具有随机名称的工作簿（例如export！-097a0sdk.xls），这就是为什么我需要一个快捷方式来使这项任务更容易。

这是我通过使用代码所期望的结果

这是系统生成的excel

谢谢

Answer 1

如果我理解正确，那么以下内容将遍历给定目录，它将打开并检查每个文件以获取所需信息，如果找到，它会将值添加到主工作簿中。

注意：如果文件的文件名中包含“Master”，则此代码不会打开文件。

Sub LoopThroughFolder()
Dim FSO As New FileSystemObject
Dim myFolder As Folder
Dim wb As Workbook
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim myFile As File
Dim AccNumber As String
Dim LastRow As Long, i As Long
Dim sPath As String
sPath = "C:\Work\2017"

LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
'get the last row with data on Column A
Application.DisplayAlerts = False
'do not display alerts
Set myFolder = FSO.GetFolder(sPath) 'set the root folder
    For Each myFile In myFolder.Files 'for each file in the folder
        If InStr(myFile.Name, "Master") = 0 Then
        'if file to open does not have "Master" in it's name then
            Set wb = Workbooks.Open(myFile.Path) 'open the file
            AccNumber = wb.Sheets(1).Range("B2") 'check for account number on first Sheet
            For i = 1 To LastRow 'loop through current Sheet to check if we have a match for the account number
                If ws.Cells(i, 1) = AccNumber Then 'if match
                ws.Cells(i, 2) = wb.Sheets(1).Range("B9") 'pass the values from the required range
                ws.Cells(i, 3) = wb.Sheets(1).Range("E9")
                End If
            Next i
            wb.Close False 'close and do not save changes
            Set wb = Nothing
        End If
    Next
Application.DisplayAlerts = True
End Sub

此外，您可能必须设置对相关库的引用才能使用FileSystemObject来执行此操作：

How do I use FileSystemObject in VBA?

在Excel中，您需要设置对VB脚本运行时库的引用。 相关文件通常位于\Windows\System32\scrrun.dll

• 要引用此文件，请加载 Visual Basic编辑器（ ALT + F11 ）
• 选择工具＆gt;下拉菜单中的参考文献
• 将显示可用参考的列表框
• 勾选“Microsoft Scripting Runtime”
旁边的复选框
• scrrun.dll文件的全名和路径将显示在列表框
下方
• 点击确定按钮。