VBA多工作簿提取数据

淘豆爸

求帮助！需要把多个文件中指定的数据按照汇总表的表头提取出来，每个文件的格式固定，那位大神帮写段代码，最好是设置选择文件的。之前可能没表达清楚，基本每月都需要汇总

3190496160

Sub 取数()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
ReDim arr(1 To Sheets.Count)
With Sheets("数据汇总")
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ar = .Range("a1:h" & r + 1)
    For j = 2 To UBound(ar, 2)
        If Trim(ar(1, j)) = "" Then ar(1, j) = ar(1, j - 1)
        zd = Trim(ar(1, j)) & "|" & Trim(ar(2, j))
        d(zd) = j
    Next j
    lj = ThisWorkbook.Path
    VBA.ChDir lj
    Filename = Application.GetOpenFilename("Excel 文件 ,*.xls*;*.xls*")
    If Filename = False Then MsgBox "您没有选择文件！": Exit Sub
    Set wb = Workbooks.Open(Filename)
    With wb.Worksheets("状态")
        rs = .Cells(Rows.Count, 2).End(xlUp).Row
        br = .Range("b2:f" & rs)
    End With
    wb.Close False
    xh = r + 1
    For i = 3 To UBound(br)
        For j = 2 To UBound(br, 2)
            zd = Trim(br(i, 1)) & "|" & Trim(br(2, j))
            lh = d(zd)
            If lh <> "" Then
                ar(xh, lh) = br(i, j)
                ar(xh, 1) = br(1, 1)
            End If
        Next j
    Next i
    .Range("a1:h" & r + 1) = ar
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

测试数据.rar (38.36 KB, 下载次数: 24)

2023-2-5 16:36 上传

点击文件名下载附件

淘豆爸

非常感谢，我试下效果

淘豆爸

3190496160 发表于 2023-2-5 16:35
Sub 取数()
Application.ScreenUpdating = False
Dim ar As Variant

能修改成多文件选取么

明天会更好zj

淘豆爸 发表于 2023-2-5 19:01
能修改成多文件选取么

当然可以多选，改getopenfilename的参数

gwjkkkkk

Option Explicit
Sub test()
    Dim Items As FileDialogSelectedItems, strPath$
    Dim ar, br, i&, j&, r&, dic As Object, vKey, vItem
   
    strPath = ThisWorkbook.Path & "\"
    With Application.FileDialog(1)
        With .Filters
            .Clear
            .Add "Excel Files", "*.xlsx"
        End With
        .AllowMultiSelect = True
        .InitialFileName = strPath
        If .Show Then Set Items = .SelectedItems Else Exit Sub
    End With
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
        With [A1].CurrentRegion
           r = .Rows.Count
           ar = .Resize(1000)
        End With
        For i = 2 To UBound(ar, 2)
           If (ar(1, i)) = "" Then ar(1, i) = ar(1, i - 1)
           vKey = ar(1, i) & ar(2, i)
           dic(vKey) = i
        Next i
        For Each vItem In Items
           With GetObject(vItem)
             br = .Sheets(2).[B2].CurrentRegion
             r = r + 1
             For i = 3 To UBound(br)
                ar(r, 1) = br(1, 1)
                For j = 2 To UBound(br, 2)
                   vKey = br(i, 1) & br(2, j)
                   If dic.exists(vKey) Then
                      ar(r, dic(vKey)) = br(i, j)
                   End If
                Next j
             Next i
            .Close False
           End With
        Next
        
        
    Columns(1).NumberFormatLocal = "yyyy-mm-dd"
    [A1].Resize(UBound(ar), UBound(ar, 2)) = ar
    Set Items = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

淘豆爸 发表于 2023-2-5 19:01
能修改成多文件选取么

请楼主参考附件，如果满意，右下角评分。。。

淘豆爸

gwjkkkkk 发表于 2023-2-5 19:54
请楼主参考附件，如果满意，右下角评分。。。

多谢，等现在外面，等回去试下

dcanoe

很多经典代码可以复制下来平时使用，有人帮助真心好