多表再汇总

simpman · 发表于 2014-12-13 11:28

请大侠们看一看我这个表有没有什么办法汇总，每张表每个类别行不固定，要求汇总金额，先谢了。

cbtaja · 发表于 2014-12-13 12:50

Sub cs()
Set dic = CreateObject("Scripting.dictionary")
Dim brr(0 To 999, 0 To 10)
brr(0, 0) = "表名"
For Each sht In Sheets
If sht.Name <> "汇总" Then
arr = sht.Range("A1").CurrentRegion
n = n + 1
brr(n, 0) = sht.Name
For i = 2 To UBound(arr)
If Len(arr(i, 6)) = 0 Then arr(i, 6) = arr(i - 1, 6)
If dic.exists(arr(i, 6)) Then
p = dic(arr(i, 6))
brr(n, p) = brr(n, p) + arr(i, 9)
Else
k = k + 1
dic(arr(i, 6)) = k
brr(0, k) = arr(i, 6)
brr(n, k) = arr(i, 9)
End If
Next
End If
Next
With Sheet1.Range("A2")
.CurrentRegion.ClearContents
.Resize(n + 1, k + 1) = brr
End With
End Sub

复制代码

LangQueS · 发表于 2014-12-13 12:54

" 楼主在设计数据表时，未考虑到充分发挥Excel软件的内置功能，对以后数据的积累、修改、引用和汇总造成了很大困难……
建议楼主参考下帖附件中的文字说明，修改工作表的设置，首先建立好记录日常所发生数据的“一维数据表”。我们的目的是使用好Excel，实现对数据的管理，而不是制作软件。因此要充分发挥 Excel 自带的强大功能，例如“高级筛选”、“数据透视表”等等，再用函数和代码等方法作为补充，以降低制作和修改难度，提高工作效率。
以上浅见是个人观点，不代表论坛立场。"

★Excel数据管理的一般规律★ http://club.excelhome.net/thread-287461-1-1.html

simpman · 发表于 2014-12-13 13:08

cbtaja 发表于 2014-12-13 12:50

大师，无需汇总部分能不能不要？

simpman · 发表于 2014-12-13 13:20

LangQueS 发表于 2014-12-13 12:54
" 楼主在设计数据表时，未考虑到充分发挥Excel软件的内置功能，对以后数据的积累、修改、引用和汇总造成 ...

您的贴子一定会慢慢消化，不过企业那些事儿是积重难返，数据的框架结构不知是哪位爷定的，要改难，只能慢慢改良。

cbtaja · 发表于 2014-12-13 13:46

simpman 发表于 2014-12-13 13:08
大师，无需汇总部分能不能不要？

Sub cbtaja()
Set dic = CreateObject("Scripting.dictionary")
Dim brr(0 To 999, 0 To 10)
brr(0, 0) = "表名"
For Each sht In Sheets
If sht.Name <> "汇总" Then
arr = sht.Range("A1").CurrentRegion
n = n + 1
brr(n, 0) = sht.Name
For i = 2 To UBound(arr)
If Len(arr(i, 6)) = 0 Then arr(i, 6) = arr(i - 1, 6)
If InStr(1, arr(i, 6), "无需汇总") = 0 Then
If dic.exists(arr(i, 6)) Then
p = dic(arr(i, 6))
brr(n, p) = brr(n, p) + arr(i, 9)
Else
k = k + 1
dic(arr(i, 6)) = k
brr(0, k) = arr(i, 6)
brr(n, k) = arr(i, 9)
End If
End If
Next
End If
Next
With Sheet1.Range("A2")
.CurrentRegion.ClearContents
.Resize(n + 1, k + 1) = brr
End With
End Sub

复制代码

simpman · 发表于 2014-12-15 10:34

大师再麻烦您一下，表名和灰色部分能不能由手工填写不刷新，汇总部分对应刷新填入，行不行？

simpman · 发表于 2014-12-15 14:15

cbtaja 发表于 2014-12-13 13:46

请高手帮我看一下，这个怎么改？

yaozong · 发表于 2014-12-15 17:05

simpman 发表于 2014-12-15 10:34
大师再麻烦您一下，表名和灰色部分能不能由手工填写不刷新，汇总部分对应刷新填入，行不行？

Sub yy()
Sheets("汇总").Activate
Dim df, dj, arr, i&, k&, n&, f$, j$, s$
Set df = CreateObject("Scripting.dictionary")
Set dj = CreateObject("Scripting.dictionary")
For n = 6 To 12
df(Mid(Cells(2, n), 3)) = n - 5
dj(Mid(Cells(2, n + 8), 3)) = n - 5
Next
ReDim ar(1 To 999, 1 To 10)
ReDim br(1 To 999, 1 To 10)
For k = 3 To [a3].End(4).Row
s = Cells(k, 1).Value
arr = Sheets(s).UsedRange.Value
For i = 2 To UBound(arr)
If Len(arr(i, 6)) = 0 Then arr(i, 6) = arr(i - 1, 6)
If Len(arr(i, 10)) = 0 Then arr(i, 10) = arr(i - 1, 10)
f = arr(i, 6): j = arr(i, 10)
If df.exists(f) Then ar(k - 2, df(f)) = ar(k - 2, df(f)) + arr(i, 9)
If dj.exists(j) Then br(k - 2, dj(j)) = br(k - 2, dj(j)) + arr(i, 13)
Next
Next
[f3:l1000,n3:t1000] = ""
[f3].Resize(k - 2, df.Count) = ar
[n3].Resize(k - 2, dj.Count) = br
Set df = Nothing
Set dj = Nothing
End Sub

复制代码

yaozong · 发表于 2014-12-15 17:06

simpman 发表于 2014-12-15 10:34
大师再麻烦您一下，表名和灰色部分能不能由手工填写不刷新，汇总部分对应刷新填入，行不行？

参考附件

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

[求助] 多表再汇总

评分

点评

评分

评分