多表数据汇总，谢谢！

hzruziniu

蓝桥玄霜 发表于 2012-8-22 11:03
把第6句If Sht.Name  "汇总" Then  改为：（别的工作表的名字为"不要汇总" 的话）
If Sht.Name  "汇总" an ...

蓝老师:如果只汇总1月至12月,其他的表不汇总又如何修改代码 多表汇总（求助）0822.rar (38.81 KB, 下载次数: 43)

2012-8-24 21:20 上传

点击文件名下载附件

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Sht As Worksheet, Myr&, m&
   
3. Application.ScreenUpdating = False
   
4. Sheet21.Activate
   
5. For Each Sht In Sheets
   
6.     If InStr(Sht.Name, "月") Then
   
7.         Myr = Sht.[a65536].End(xlUp).Row
   
8.         m = [a65536].End(xlUp).Row + 1
   
9.         If Myr >= 4 Then
   
10.             Cells(m, 1).Resize(Myr - 3, 10) = Sht.[a4].Resize(Myr - 3, 10).Value
    
11.         End If
    
12.     End If
    
13. Next
    
14. Application.ScreenUpdating = True
    
15. End Sub
    

复制代码

蓝桥玄霜

请见附件。

wanggfcn

mzbao 发表于 2012-8-24 20:02
计算后的结果放在汇总的L列，看看符不符合

老师！谢谢！如果再将数量再和重量一样进行运算，该怎样增加代码？可以增加到M列。再次谢谢！

Albert128

蓝桥玄霜 发表于 2012-8-25 08:57
请见附件。

请问蓝板,如果是取任意工作表1(设为变量)至任意工作表2(设为变量)的多表求和,代码又何修改呢?

蓝桥玄霜

Albert128 发表于 2012-8-25 21:57
请问蓝板,如果是取任意工作表1(设为变量)至任意工作表2(设为变量)的多表求和,代码又何修改呢?

一般没有规律的不大好做。
象你的这个要从表格排列的次序来判断，如从sheets(10) 到 Sheets(13)

Albert128

蓝桥玄霜 发表于 2012-8-26 09:32
一般没有规律的不大好做。
象你的这个要从表格排列的次序来判断，如从sheets(10) 到 Sheets(13)

您好!附件我是用函数做的,但存在两个缺点:
1、项目不随子表更新而更新
2、数据多时速度很慢；
所以,希望得到你帮助用代码来解决.

蓝桥玄霜

1124的科目名称是什么？

Albert128

蓝桥玄霜 发表于 2012-8-26 12:09
1124的科目名称是什么？

您好!是会计上为了品牌之间的核算,"内部往来"科目,借方=贷方,所以余额为0

蓝桥玄霜

1. Sub lqxs()
   
2. Dim DD As New Dictionary
   
3. Dim d1 As New Dictionary
   
4. Dim DD1 As New Dictionary
   
5. Dim d As New Dictionary
   
6. Dim Arr, i&, ks, js, j&, Sht As Worksheet
   
7. Dim k, t, kk, r%, Arr1(), x$, k1, k2
   
8. On Error Resume Next
   
9. 
   
10. Sheet3.Activate
    
11. [a2].Resize(2000, 3).ClearContents
    
12. ks = Val([f1].Value): js = Val([h1].Value)
    
13. For j = ks To js
    
14.     Set Sht = Sheets(j)
    
15.     Arr = Sht.[a1].CurrentRegion
    
16.     For i = 2 To UBound(Arr) - 1
    
17.         If Left(Arr(i, 2), 1) <> "[" Then
    
18.             DD(Arr(i, 1)) = ""
    
19.             If DD.Exists(Arr(i, 1)) Then Set DD(Arr(i, 1)) = New Dictionary: Set DD1(Arr(i, 1)) = New Dictionary
    
20.         End If
    
21.     Next
    
22. Next
    
23. For j = ks To js
    
24.     Set Sht = Sheets(j)
    
25.     Arr = Sht.[a1].CurrentRegion
    
26.     For i = 2 To UBound(Arr) - 1
    
27.         If Left(Arr(i, 2), 1) <> "[" Then
    
28.             x = Arr(i, 1) & Arr(i, 2)
    
29.             d(x) = d(x) + Arr(i, 10)
    
30.             d1(x) = d1(x) + Arr(i, 11)
    
31.         Else
    
32.             x = "    " & Arr(i, 2)
    
33.             DD(Arr(i, 1))(x) = DD(Arr(i, 1))(x) + Arr(i, 10)
    
34.             DD1(Arr(i, 1))(x) = DD1(Arr(i, 1))(x) + Arr(i, 11)
    
35.         End If
    
36.     Next
    
37. Next
    
38. k = DD.Keys
    
39. k1 = d.Keys
    
40. For i = 0 To UBound(k)
    
41.     r = r + 1
    
42.     ReDim Preserve Arr1(1 To 3, 1 To r)
    
43.     Arr1(1, r) = k1(i)
    
44.     Arr1(2, r) = d(k1(i))
    
45.     Arr1(3, r) = d1(k1(i))
    
46.    If UBound(DD(k(i))) <> -1 Then
    
47.         kk = DD(k(i)).Keys
    
48.         For j = 1 To DD(k(i)).Count
    
49.             r = r + 1
    
50.             ReDim Preserve Arr1(1 To 3, 1 To r)
    
51.             Arr1(1, r) = kk(j - 1)
    
52.             Arr1(2, r) = DD(k(i))(kk(j - 1))
    
53.             Arr1(3, r) = DD1(k(i))(kk(j - 1))
    
54.         Next
    
55.     End If
    
56. Next
    
57. [a2].Resize(UBound(Arr1, 2), UBound(Arr1)) = Application.Transpose(Arr1)
    
58. Cells(UBound(Arr1, 2) + 2, 1) = "合计"
    
59. Cells(UBound(Arr1, 2) + 2, 2).Formula = "=sum(r2c:r[-1])"
    
60. Cells(UBound(Arr1, 2) + 2, 3).Formula = "=sum(r2c:r[-1])"
    
61. End Sub
    

复制代码