[已解决]Excel多表汇总

张雄友

Excel多表汇总。

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-12 21:08

1. Sub Macro1()
   
2. Dim arr, brr(1 To 60000, 1 To 200), d, i%, j&, k%, k2%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. h = 1: l = 1
   
5. For i = 1 To Sheets.Count
   
6.     If Sheets(i).Name <> "汇总" And Application.CountA(Sheets(i).UsedRange) > 1 Then
   
7.         arr = Sheets(i).Range("a1").CurrentRegion
   
8.         For k = 2 To UBound(arr, 2)
   
9.             If Not d.exists(arr(1, k)) Then
   
10.                 l = l + 1
    
11.                 d(arr(1, k)) = l
    
12.                 brr(1, l) = arr(1, k)
    
13.             End If
    
14.         Next
    
15.         For j = 2 To UBound(arr)
    
16.             If Not d.exists(arr(j, 1)) Then
    
17.                 h = h + 1
    
18.                 d(arr(j, 1)) = h
    
19.                 brr(h, 1) = arr(j, 1)
    
20.                 For k2 = 2 To UBound(arr, 2)
    
21.                     brr(h, d(arr(1, k2))) = arr(j, k2)
    
22.                 Next
    
23.             Else
    
24.                 h2 = d(arr(j, 1))
    
25.                 For k3 = 2 To UBound(arr, 2)
    
26.                     brr(h2, d(arr(1, k3))) = brr(h2, d(arr(1, k3))) + arr(j, k3)
    
27.                 Next
    
28.             End If
    
29.         Next
    
30.     End If
    
31. Next
    
32. brr(1, 1) = "名称"
    
33. Sheets("汇总").Activate
    
34. Range("i1").Resize(h, l) = brr
    
35. End Sub

复制代码

跳转到最佳答案楼层

C.Deny

ALT+D+P调出透视表向导
多表合并.rar (542.71 KB, 下载次数: 44)

2014-12-11 21:00 上传

点击文件名下载附件

dsmch

1. Sub Macro1()
   
2. Dim arr, brr(1 To 60000, 1 To 6), d, i%, j&, k%, k2%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. For i = 1 To Sheets.Count
   
5.     If Sheets(i).Name <> "汇总" And Application.CountA(Sheets(i).UsedRange) > 1 Then
   
6.         arr = Sheets(i).Range("a1").CurrentRegion
   
7.         For j = 2 To UBound(arr)
   
8.             If Not d.exists(arr(j, 1)) Then
   
9.                 s = s + 1
   
10.                 d(arr(j, 1)) = s
    
11.                 For k = 1 To UBound(arr, 2)
    
12.                     brr(s, k) = arr(j, k)
    
13.                 Next
    
14.             Else
    
15.                 n = d(arr(j, 1))
    
16.                 For k2 = 2 To UBound(arr, 2)
    
17.                     brr(n, k2) = brr(n, k2) + arr(j, k2)
    
18.                 Next
    
19.             End If
    
20.         Next
    
21.     End If
    
22. Next
    
23. Sheets("汇总").Activate
    
24. Range("i2").Resize(s, UBound(brr, 2)) = brr
    
25. End Sub

复制代码

张雄友

dsmch 发表于 2014-12-12 08:56

怎么标题字段不是自动生成的？谢谢！

dsmch

1. Sub Macro1()
   
2. Dim arr, brr(1 To 60000, 1 To 200), d, i%, j&, k%, k2%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. h = 1: l = 1
   
5. For i = 1 To Sheets.Count
   
6.     If Sheets(i).Name <> "汇总" And Application.CountA(Sheets(i).UsedRange) > 1 Then
   
7.         arr = Sheets(i).Range("a1").CurrentRegion
   
8.         For k = 2 To UBound(arr, 2)
   
9.             If Not d.exists(arr(1, k)) Then
   
10.                 l = l + 1
    
11.                 d(arr(1, k)) = l
    
12.                 brr(1, l) = arr(1, k)
    
13.             End If
    
14.         Next
    
15.         For j = 2 To UBound(arr)
    
16.             If Not d.exists(arr(j, 1)) Then
    
17.                 h = h + 1
    
18.                 d(arr(j, 1)) = h
    
19.                 brr(h, 1) = arr(j, 1)
    
20.                 For k2 = 2 To UBound(arr, 2)
    
21.                     brr(h, d(arr(1, k2))) = arr(j, k2)
    
22.                 Next
    
23.             Else
    
24.                 h2 = d(arr(j, 1))
    
25.                 For k3 = 2 To UBound(arr, 2)
    
26.                     brr(h2, d(arr(1, k3))) = brr(h2, d(arr(1, k3))) + arr(j, k3)
    
27.                 Next
    
28.             End If
    
29.         Next
    
30.     End If
    
31. Next
    
32. brr(1, 1) = "名称"
    
33. Sheets("汇总").Activate
    
34. Range("i1").Resize(h, l) = brr
    
35. End Sub

复制代码

张雄友

dsmch 发表于 2014-12-12 21:08

怎么让那些 0 值不显示出来？

dsmch

工具、选项、视图、零值前钩去掉