一键汇总各公司财务报表数据到总表，且汇总表每一单元格显示各公司累计过程。

AiYx · 发表于 2024-2-6 13:55

请各位老师帮一下，感谢各位老师：
想实现的功能：一键键汇总各公司财务报表数据到总表，且汇总表每一单元格显示各公司累计过程。如附件内截图“功能需求”。

功能需求：汇总各公司数据到总表.jpg

kittli · 发表于 2024-2-6 16:14

参与一下！！！

ykcbf1100 · 发表于 2024-2-6 16:33

本帖最后由 ykcbf1100 于 2024-2-6 17:43 编辑

参与一下。。。

ykcbf1100 · 发表于 2024-2-6 16:34

代码供参考。。。

Sub ykcbf() '//2024.2.6
Set Fso = CreateObject("scripting.filesystemobject")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ws = ThisWorkbook
fns = [{"资产负债表","利润表"}]
p = ws.Path & "\各公司财务报表"
For x = 1 To 2
Set sht = ws.Worksheets(fns(x))
zrr = sht.UsedRange
For Each f In Fso.GetFolder(p).Files
If f.Name Like "*.xls" Then
fn = Fso.GetBaseName(f)
Set wb = Workbooks.Open(f, 0)
With wb.Sheets(sht.Name)
arr = .UsedRange
wb.Close False
End With
If x = 1 Then
For j = 1 To UBound(arr, 2) Step 4
For i = 5 To UBound(arr)
zrr(i, j + 2) = zrr(i, j + 2) + arr(i, j + 2)
zrr(i, j + 3) = zrr(i, j + 3) + arr(i, j + 3)
Next
Next
Else
For i = 4 To UBound(arr)
zrr(i, 3) = zrr(i, 3) + arr(i, 3)
zrr(i, 4) = zrr(i, 4) + arr(i, 4)
zrr(i, 5) = zrr(i, 5) + arr(i, 5)
Next
End If
End If
Next f
sht.UsedRange = zrr
Next
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

AiYx · 发表于 2024-2-6 16:41

找了代码，现在运行有几个问题，一个是资产负债表C5:D19粘贴错位，汇总结果是一个最终合计数（如300,000.00），没有能显示计算过程（如=100,000.00+200,000.00）.

请各位老师

Sub ConsolidateData()
Dim FolderPath As String
Dim FileName As String
Dim WB As Workbook
Dim WS As Worksheet
Dim WSConsolidate1 As Worksheet
Dim WSConsolidate2 As Worksheet
Dim SumRange1 As Range
Dim SumRange2 As Range
Application.ScreenUpdating = False '取消屏幕刷新
' 设置文件夹路径
FolderPath = "D:\Desktop\附件\各公司财务报表" ' 请替换为你的文件夹路径
FileName = Dir(FolderPath & "*.xls*") ' 假设工作簿是xls或xlsx格式
' 设置当前工作簿的汇总工作表
Set WSConsolidate1 = ThisWorkbook.Sheets("资产负债表") ' 假设第一个汇总工作表名为"资产负债表"
Set WSConsolidate2 = ThisWorkbook.Sheets("利润表") ' 假设第二个汇总工作表名为"利润表"
' 设置要汇总的范围
Set SumRange1 = WSConsolidate1.Range("C6:D19,C22:D43,G5:H20,G23:H32,G36:H44,G46:H46")
Set SumRange2 = WSConsolidate2.Range("C4:E53")
' 清除之前的汇总数据
SumRange1.ClearContents
SumRange2.ClearContents
' 开始遍历文件夹中的每个工作簿
Do While FileName <> ""
' 打开工作簿
Set WB = Workbooks.Open(FolderPath & FileName)
' 遍历工作簿中的每个工作表
For Each WS In WB.Worksheets
' 检查工作表名称是否与汇总工作簿中的工作表名称匹配
If WS.Name = WSConsolidate1.Name Then
' 累加第一个范围的数据
For Each cell In SumRange1
If Not IsEmpty(WS.Range(cell.Address).Value) Then
WSConsolidate1.Range(cell.Address).Value = _
WSConsolidate1.Range(cell.Address).Value + WS.Range(cell.Address).Value
End If
Next cell
ElseIf WS.Name = WSConsolidate2.Name Then
' 累加第二个范围的数据
For Each cell In SumRange2
If Not IsEmpty(WS.Range(cell.Address).Value) Then
WSConsolidate2.Range(cell.Address).Value = _
WSConsolidate2.Range(cell.Address).Value + WS.Range(cell.Address).Value
End If
Next cell
End If
Next WS
' 关闭工作簿，不保存更改
WB.Close SaveChanges:=False
' 获取下一个工作簿名称
FileName = Dir()
Loop
' 代码结束
Application.ScreenUpdating = True '恢复屏幕刷新
End Sub

复制代码

优化一下，新年快乐。

cjc209 · 发表于 2024-2-6 16:48

ykcbf1100 发表于 2024-2-6 16:33
参与一下。。。

他要                               If ar(j, k) <> "" Then
                                          br(i, k) = "=" & br(i, k) & "+" & ar(i, k)
                                       End If
这种效果

yynrzwh · 发表于 2024-2-6 16:49

附件-0206.rar (231.33 KB, 下载次数: 41)

cjc209 · 发表于 2024-2-6 16:49

就是结果是有那几笔数相加的

AiYx · 发表于 2024-2-6 16:51

kittli 发表于 2024-2-6 16:14
参与一下！！！

非常感谢老师！！！

测试可用，学习了。先再问一下老师，可以实现汇总结果是一个最终合计数（如300,000.00），没有能显示计算过程（如=100,000.00+200,000.00）吗？

cjc209 · 发表于 2024-2-6 16:55

但这要自由最后两个还是没有每一笔组成明细

		自动登录	找回密码
密码			免费注册

[求助] 一键汇总各公司财务报表数据到总表，且汇总表每一单元格显示各公司累计过程。

评分

评分

评分