ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 390|回复: 24

文件夹下多工作簿汇总

[复制链接]

TA的精华主题

TA的得分主题

发表于 2024-4-2 08:06 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
文件夹下多工作簿按科目名称来汇总 期初余额借方,期初余额贷方,本期发生借方,本期发生贷方,期末余额借方,期末余额贷方

汇总后在文件下另外生成一个工作簿 余额表.rar (6.43 KB, 下载次数: 15)
文件夹下现在是二个工作簿,但是不一定是二个,有可能是多个
image.png

TA的精华主题

TA的得分主题

发表于 2024-4-2 08:13 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2024-4-2 08:19 | 显示全部楼层
小计合计要汇总吗?如果按科目名称汇总的话,小计合计应该不要吧

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-4-2 08:27 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
ykcbf1100 发表于 2024-4-2 08:19
小计合计要汇总吗?如果按科目名称汇总的话,小计合计应该不要吧

不要,谢谢

TA的精华主题

TA的得分主题

发表于 2024-4-2 08:46 | 显示全部楼层
论坛中多工作簿汇总的例子非常多

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-4-2 08:48 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2024-4-2 08:49 | 显示全部楼层
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

TA的精华主题

TA的得分主题

发表于 2024-4-2 08:49 | 显示全部楼层
附件供参考。。。

余额表.7z

25.67 KB, 下载次数: 20

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2024-4-2 08:50 | 显示全部楼层
模拟结果供参考。。。。

余额表.zip

25.3 KB, 下载次数: 10

TA的精华主题

TA的得分主题

发表于 2024-4-2 08:50 | 显示全部楼层
参与一下。。。

  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
复制代码


您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-4-13 04:57 , Processed in 0.046477 second(s), 13 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表