使用vb批量提取文件下所有表格，并复制内容到符合要求的另一表格单元格内

[Dbqwyban12]

图1是正在使用的表格，图2是格式相同数据不同的excel文件之一，需要打开图2的表格，把K列图示几个数据复制到，图1中B列编号与图2中A6相同编号的C D E F G H列对应行的位置

[Dbqwyban12]

图2表格可能有几十、上百、上千个excel表，名称不同，A6及其它数据不同，格式完全一样，图2的表格需要的数据都在SHEET(AC)

[humanmagic]

运行后弹出文件选择对话框，选择要汇总的文件(可以多选)后确定

Sub demo()
    Dim i As Long, arr, tempArr, d As Object
    Set d = CreateObject("scripting.dictionary")
    arr = Range(Cells(5, 2), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 7)).Value
    For i = 1 To UBound(arr)
        d(arr(i, 1) & "") = i
    Next i
    With Application.FileDialog(msoFileDialogOpen)
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "Excel 文件(*.xl*)", "*.xl*"
        .Title = "选择汇总表"
        .Show
        On Error Resume Next
        For i = 1 To .SelectedItems.Count
            With Workbooks.Open(.SelectedItems(i))
                With .Sheets("AC")
                    tempArr = .Range("A6:E11").Value
                    arr(d(tempArr(1, 1) & ""), 2) = tempArr(1, 5)
                    arr(d(tempArr(1, 1) & ""), 3) = tempArr(2, 5)
                    arr(d(tempArr(1, 1) & ""), 4) = tempArr(3, 5)
                    arr(d(tempArr(1, 1) & ""), 5) = tempArr(4, 5)
                    arr(d(tempArr(1, 1) & ""), 6) = tempArr(5, 5)
                    arr(d(tempArr(1, 1) & ""), 7) = tempArr(6, 5)
                End With
                .Close False
            End With
        Next i
        Err.Number = 0
        On Error GoTo 0
        Range(Cells(5, 2), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 7)).Value = arr
    End With
End Sub