求助各位大大，关于报表合并问题

chenjian8579 · 发表于 2016-10-9 22:19

各位神大大好，现在我在工作中遇到难题，得知论坛神人众多，请帮帮小弟。
目前有大量同格式但不同工作簿的资产负债表和利润表要合并计算，想新建一张汇总表把资产负债表合计数合并到SHEET1，利润表合计数汇总到表2，请问有没有宏能实现，在此多谢，例子在下面附件中

lsc900707 · 发表于 2016-10-9 23:22

好像不是最新的财务报表样式>>>>>>>>>>

lsc900707 · 发表于 2016-10-9 23:31

参考附件内容，看看能否帮到你：

duquancai · 发表于 2016-10-10 08:46

打开附件中的汇总表，点击按钮》》》》》》》》》》》》》》》自己再加个字典进行汇总吧！！！！

Sub SQL加数组()
Dim cx As New 类1, sql1$, sql2$, sqlz$, sqll$, p$, f$, pa$, b As Boolean
p = ThisWorkbook.Path & "": pa = ThisWorkbook.FullName
f = Dir(p & "*.xls*")
Do While f <> ""
If p & f = pa Then GoTo 100
If Not b Then
sql1 = "select * from [" & p & f & "].[资产负债表$a4:h54]"
sql2 = "select * from [" & p & f & "].[利润表$a4:j34]"
b = True
Else
sql1 = sql1 & " union all select * from [" & p & f & "].[资产负债表$a4:h54]"
sql2 = sql2 & " union all select * from [" & p & f & "].[利润表$a4:j34]"
End If
100 f = Dir
Loop
sqlz = "select * from (" & sql1 & ")"
sqll = "select * from (" & sql2 & ")"
arrz = cx.筛选结果(pa, sqlz)
arrl = cx.筛选结果(pa, sqll)
Sheet1.Cells.ClearContents: Sheet2.Cells.ClearContents
Sheet1.Range("a1:h1") = Array("资产", "行次", " 期末余额", "年初余额", "负债和所有者(或股东权益)", "行次", "期末余额", "年初余额")
Sheet2.Range("a1:j1") = Array("项目", "行次", "本期金额", "本年累计", "上年同期数", "项目", "行次", "本期金额", "本年累计", "上年同期数")
Sheet1.Range("a2").Resize(UBound(arrz) + 1, UBound(arrz, 2) + 1) = arrz
Sheet2.Range("a2").Resize(UBound(arrl) + 1, UBound(arrl, 2) + 1) = arrl
End Sub

复制代码

duquancai · 发表于 2016-10-10 08:49

附件在这里》》》》》》》》》》》》》》。

duquancai · 发表于 2016-10-10 19:34

本帖最后由 duquancai 于 2016-10-10 20:09 编辑

请下载附件测试》》》》》》》》》》》

Sub SQL加数组加字典()
Dim cx As New 类1, sql1$, sql2$, sqlz$, sqll$, p$, f$, pa$, b As Boolean
Dim d As Object, arr1(1 To 10000, 1 To 8), arr2(1 To 10000, 1 To 10), i&, n&, j&, k&, m&
Set d = CreateObject("Scripting.Dictionary")
p = ThisWorkbook.Path & "": pa = ThisWorkbook.FullName
f = Dir(p & "*.xls*")
Do While f <> ""
If p & f = pa Then GoTo 100
If Not b Then
sql1 = "select * from [" & p & f & "].[资产负债表$a4:h]"
sql2 = "select * from [" & p & f & "].[利润表$a4:j]"
b = True
Else
sql1 = sql1 & " union all select * from [" & p & f & "].[资产负债表$a4:h]"
sql2 = sql2 & " union all select * from [" & p & f & "].[利润表$a4:j]"
End If
100 f = Dir
Loop
arr = cx.筛选结果(pa, sql1): brr = cx.筛选结果(pa, sql2)
For i = 0 To UBound(arr, 2)
If Not d.exists(arr(0, i)) Then
n = n + 1
d(arr(0, i)) = n
For j = 1 To 8
arr1(n, j) = arr(j - 1, i)
Next
Else
m = d(arr(0, i))
arr1(m, 3) = arr1(m, 3) + arr(2, i)
arr1(m, 4) = arr1(m, 4) + arr(3, i)
arr1(m, 7) = arr1(m, 7) + arr(6, i)
arr1(m, 8) = arr1(m, 8) + arr(7, i)
End If
Next
Sheet1.Cells.ClearContents: Sheet2.Cells.ClearContents
Sheet1.Range("c:d,g:h").NumberFormat = "_ * #,##0.00_ ;_ * -#,##0.00_ ;_ * ""-""_ ;_ @_ "
Sheet1.Range("a1:h1") = Array("资产", "行次", " 期末余额", "年初余额", "负债和所有者(或股东权益)", "行次", "期末余额", "年初余额")
Sheet1.Range("a2").Resize(10000, 8) = arr1
d.RemoveAll: n = 0: m = 0
For i = 0 To UBound(brr, 2)
If Not d.exists(brr(0, i)) Then
n = n + 1
d(brr(0, i)) = n
For j = 1 To 10
arr2(n, j) = brr(j - 1, i)
Next
Else
m = d(brr(0, i))
For x = 3 To 5
arr2(m, x) = arr2(m, x) + brr(x - 1, i)
Next
For x = 8 To 10
arr2(m, x) = arr2(m, x) + brr(x - 1, i)
Next
End If
Next
Sheet2.Range("c:e,h:j").NumberFormat = "_ * #,##0.00_ ;_ * -#,##0.00_ ;_ * ""-""_ ;_ @_ "
Sheet2.Range("a1:j1") = Array("项目", "行次", "本期金额", "本年累计", "上年同期数", "项目", "行次", "本期金额", "本年累计", "上年同期数")
Sheet2.Range("a2").Resize(10000, 10) = arr2
End Sub

复制代码

chenjian8579 · 发表于 2017-6-24 18:40

感谢大神，论坛果然高手众多

lsc900707 · 发表于 2017-6-24 19:52

chenjian8579 发表于 2017-6-24 18:40
感谢大神，论坛果然高手众多

你的意思是代码给你几个月了，现在才看到？

chenjian8579 · 发表于 2017-6-24 20:05

不好意思，一开始没指望有人回复，所以没上论坛，想不到真会回复，感谢！

lsc900707 · 发表于 2017-6-24 20:34

chenjian8579 发表于 2017-6-24 20:05
不好意思，一开始没指望有人回复，所以没上论坛，想不到真会回复，感谢！

“没指望” 说明你对excelhome 这个大家庭不够了解。

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

求助各位大大，关于报表合并问题

评分