文件夹下多工作簿汇总

dgzwz

文件夹下多工作簿按科目名称来汇总 期初余额借方，期初余额贷方，本期发生借方，本期发生贷方，期末余额借方，期末余额贷方

汇总后在文件下另外生成一个工作簿 余额表.rar (6.43 KB, 下载次数: 15)

2024-4-2 08:04 上传

点击文件名下载附件

文件夹下现在是二个工作簿，但是不一定是二个，有可能是多个

无敌小猪猪

论坛里搜索下多表合并的例子

ykcbf1100

小计合计要汇总吗？如果按科目名称汇总的话，小计合计应该不要吧

dgzwz

ykcbf1100 发表于 2024-4-2 08:19
小计合计要汇总吗？如果按科目名称汇总的话，小计合计应该不要吧

不要，谢谢

LIUZHU

论坛中多工作簿汇总的例子非常多

dgzwz

LIUZHU 发表于 2024-4-2 08:46
论坛中多工作簿汇总的例子非常多

大都是合并，没有汇总

liulang0808

Sub 按钮1_Click()
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "请选择对应文件夹件"
        .AllowMultiSelect = False
        If .Show Then pth = .SelectedItems(1) Else Exit Sub
    End With
    Set d = CreateObject("scripting.dictionary")
    Set fso = CreateObject("scripting.filesystemobject")
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    ActiveSheet.UsedRange.Offset(1).ClearContents
    arr = [a1].Resize(9999, 7)
    r = 1
    For Each f In fso.getfolder(pth).Files
        If InStr(f.Name, ThisWorkbook.Name) = 0 Then
            With Workbooks.Open(f)
                brr = .Sheets(1).UsedRange
                For j = 2 To UBound(brr)
                    If Len(brr(j, 3)) > 0 Then
                        If d.exists(brr(j, 3)) Then
                            rx = d(brr(j, 3))
                        Else
                            r = r + 1
                            d(brr(j, 3)) = r
                            rx = r
                            arr(r, 1) = brr(j, 3)
                        End If
                        For i = 2 To UBound(arr, 2)
                            arr(r, i) = Val(arr(r, i)) + Val(brr(j, i + 2))
                        Next i
                    End If
                Next j
                .Close False
            End With
        End If
    Next f
    [a1].Resize(r, 7) = arr
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

ykcbf1100

附件供参考。。。

liulang0808

模拟结果供参考。。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.2
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     Set sh = ThisWorkbook.Sheets("汇总")
   
7.     p = ThisWorkbook.Path & ""
   
8.     bt = 1: m = 0
   
9.     On Error Resume Next
   
10.     ReDim brr(1 To 10000, 1 To 100)
    
11.     For Each f In fso.GetFolder(p).Files
    
12.         If f.Name Like "*.xls*" Then
    
13.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
14.                 fn = fso.GetBaseName(f)
    
15.                 Set wb = Workbooks.Open(f, 0)
    
16.                 arr = wb.Sheets(1).UsedRange
    
17.                 wb.Close False
    
18.                 For i = bt + 1 To UBound(arr)
    
19.                     s = CStr(arr(i, 2))
    
20.                     If Val(s) Then
    
21.                         If Not d.exists(s) Then
    
22.                             m = m + 1
    
23.                             d(s) = m
    
24.                             For j = 2 To UBound(arr, 2)
    
25.                                 brr(m, j - 1) = brr(m, j - 1) + arr(i, j)
    
26.                             Next
    
27.                         Else
    
28.                             r = d(s)
    
29.                             For j = 4 To UBound(arr, 2)
    
30.                                 brr(r, j - 1) = brr(r, j - 1) + arr(i, j)
    
31.                             Next
    
32.                         End If
    
33.                     End If
    
34.                 Next
    
35.             End If
    
36.         End If
    
37.     Next f
    
38.     With sh
    
39.         .UsedRange.Offset(1).Clear
    
40.         .[a1].Resize(1, UBound(arr, 2) - 1).Interior.Color = 49407
    
41.         .Columns(1).NumberFormatLocal = "@"
    
42.         With .[a2].Resize(m, UBound(arr, 2) - 1)
    
43.             .Value = brr
    
44.             .Borders.LineStyle = 1
    
45.             .HorizontalAlignment = xlCenter  '//列居中
    
46.             .VerticalAlignment = xlCenter
    
47.         End With
    
48.         .[a2].Resize(m, UBound(arr, 2) - 1).Sort .[a2], 1
    
49.         ActiveWindow.DisplayZeros = False
    
50.     End With
    
51.     Set d = Nothing
    
52.     Application.ScreenUpdating = True
    
53.     MsgBox "OK！"
    
54. End Sub
    

复制代码