提取任意文件夹内的所有格式统一表格里的指定内容

天涯论剑

需要做一个工具：点一按钮可以选择任意的文件夹，然后把这个文件夹里的所有表格（格式如图一，格式都统一，统一提取第一个SHEET表）的B,F,C列提取到结果表的G,H,I列（格式如图二），然后A,B,C列是根据G,H列去重然后金额汇总。如果删除文件夹里的表格，结果表的数据需保留，并且下次导入新的数据时，之前的数据也要保留，继续在下面提取。

ykcbf1100

附件供参考。。。
选当前文件夹的话，直接按确定即可。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.22
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     With Application.FileDialog(msoFileDialogFolderPicker)
   
7.         .Title = "请选择文件夹"
   
8.         .InitialFileName = ThisWorkbook.Path & ""
   
9.         If .Show = -1 Then
   
10.             p = .SelectedItems(1) & ""
    
11.         End If
    
12.     End With
    
13.     ReDim brr(1 To 10000, 1 To 3)
    
14.     For Each f In fso.GetFolder(p).Files
    
15.         If LCase$(f.Name) Like "*.xls*" Then
    
16.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
17.                 fn = fso.GetBaseName(f)
    
18.                 Set wb = Workbooks.Open(f, 0)
    
19.                 With wb.Sheets(1)
    
20.                     arr = .UsedRange
    
21.                     wb.Close False
    
22.                 End With
    
23.                 For i = 2 To UBound(arr)
    
24.                     If arr(i, 1) <> Empty Then
    
25.                         m = m + 1
    
26.                         brr(m, 1) = arr(i, 2)
    
27.                         brr(m, 2) = arr(i, 6)
    
28.                         brr(m, 3) = arr(i, 3)
    
29.                     End If
    
30.                 Next
    
31.             End If
    
32.         End If
    
33.     Next f
    
34.     ReDim zrr(1 To 10000, 1 To 3)
    
35.     With sh
    
36.         r = .Cells(Rows.Count, "g").End(3).Row
    
37.          .Columns(8).NumberFormatLocal = "@"
    
38.         .Cells(r + 1, "g").Resize(m, 3) = brr
    
39.         arr = .[g2].Resize(r + m, 3)
    
40.         .[a2:c10000] = ""
    
41.         For i = 1 To UBound(arr)
    
42.             s = arr(i, 1)
    
43.             If Not d.exists(s) Then
    
44.                 n = n + 1
    
45.                 d(s) = n
    
46.                 zrr(n, 1) = arr(i, 1)
    
47.                 zrr(n, 2) = arr(i, 2)
    
48.                 zrr(n, 3) = arr(i, 3)
    
49.             Else
    
50.                 r = d(s)
    
51.                 zrr(r, 3) = zrr(r, 3) + arr(i, 3)
    
52.             End If
    
53.         Next
    
54.         .Columns(2).NumberFormatLocal = "@"
    
55.         .[a2].Resize(n, 3) = zrr
    
56.     End With
    
57.     Application.ScreenUpdating = True
    
58. End Sub
    

复制代码

天涯论剑

ykcbf1100 发表于 2024-8-22 20:30
附件供参考。。。
选当前文件夹的话，直接按确定即可。

谢谢大神谢谢大神

lsc900707

测试参考附件：

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, br, cr, i&, j&, r&, strPath$, strFileName$, dic As Object, vKey
   
    strPath = ThisWorkbook.Path & "\"
    With Application.FileDialog(4)
        .InitialFileName = strPath
        .AllowMultiSelect = True
        If .Show Then strPath = .SelectedItems(1) & "\" Else Exit Sub
    End With
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ReDim ar(1 To 10 ^ 4, 1 To 3) As String
    cr = Array(2, 6, 3)
   
    strFileName = Dir(strPath & "*.xls")
    Do Until strFileName = ""
        If strFileName <> ThisWorkbook.Name Then
            With GetObject(strPath & strFileName)
                br = .Worksheets(1).[A1].CurrentRegion.Value
                For i = 2 To UBound(br)
                    r = r + 1
                    For j = 0 To UBound(cr)
                        ar(r, j + 1) = br(i, cr(j))
                    Next j
                Next i
                .Close False
            End With
        End If
        strFileName = Dir
    Loop
   
    [A1].CurrentRegion.Offset(1).Clear
    [G1].CurrentRegion.Offset(1).Clear
    If r Then
         [G2].Resize(r, UBound(ar, 2)).Value = ar
         For i = 1 To r
             vKey = ar(i, 1) & " " & ar(i, 2)
             dic(vKey) = dic(vKey) + Val(ar(i, 3))
         Next i
         ReDim ar(1 To dic.Count, 1 To 3)
         For j = 0 To dic.Count - 1
             br = Split(dic.keys()(j))
             ar(j + 1, 1) = br(0)
             ar(j + 1, 2) = br(1)
             ar(j + 1, 3) = dic.Items()(j)
         Next j
         [A2].Resize(UBound(ar), UBound(ar, 2)) = ar
    End If
   
    Set dic = Nothing
    Application.ScreenUpdating = True
End Sub

gwjkkkkk

。。。。。。。。。。。