[已解决]用VBA如何实现汇总？

jmhwjd

请高手帮忙：用VBA如何实现汇总。 新建 Microsoft Excel 工作表 (2).zip (3.14 KB, 下载次数: 43)

2011-12-13 14:20 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

liuguansky

2011-12-13 18:30

1. Sub JustTEST()
   
2.     Dim D As New Dictionary, Arr, i&, j As Byte, m As Byte, k&, ArrR(), S$
   
3.     For j = 3 To 8
   
4.         D.Add Cells(1, j).Value, j
   
5.     Next j
   
6.     For m = 1 To Worksheets.Count
   
7.         If Worksheets(m).Name <> "汇总" Then
   
8.             Arr = Worksheets(m).Range("A1").CurrentRegion.Value
   
9.             For j = 3 To UBound(Arr, 2)
   
10.                 Arr(1, j) = D(Arr(1, j))
    
11.             Next j
    
12.             For i = 2 To UBound(Arr)
    
13.                 S = Arr(i, 1) & Arr(i, 2)
    
14.                 If Not D.Exists(S) Then
    
15.                     k = k + 1: D.Add S, k
    
16.                     ReDim Preserve ArrR(1 To 8, 1 To k)
    
17.                     ArrR(1, k) = Arr(i, 1): ArrR(2, k) = Arr(i, 2)
    
18.                 End If
    
19.                 For j = 3 To UBound(Arr, 2)
    
20.                     ArrR(Arr(1, j), D(S)) = Arr(i, j)
    
21.                 Next j
    
22.             Next i
    
23.         End If
    
24.     Next m
    
25.     Range("a2:h" & Rows.Count).ClearContents
    
26.     Range("A2").Resize(k, 8) = Application.Transpose(ArrR)
    
27.     Range("A1").CurrentRegion.Sort Range("a1"), xlAscending, Header:=xlYes
    
28. End Sub

复制代码

看下附件是否为你所要的。

跳转到最佳答案楼层

菜鸟锐

这个思路不错，期待有人能解决。

jmhwjd

菜鸟锐 发表于 2011-12-13 14:23
这个思路不错，期待有人能解决。

主要是自己工作上的需要！

fjmxwrs

上班了，晚上来学习，先留脚印

jmhwjd

fjmxwrs 发表于 2011-12-13 14:40
上班了，晚上来学习，先留脚印

好的！但愿有高手能帮忙！

zsx720629

没有唯一标识，比如考号

jmhwjd

zsx720629 发表于 2011-12-13 14:46
没有唯一标识，比如考号

唔！相当于分类汇总！但它有一定的局限性，因而想看看有没高手可以帮忙！

liuguansky

1. Sub JustTEST()
   
2.     Dim D As New Dictionary, Arr, i&, j As Byte, m As Byte, k&, ArrR(), S$
   
3.     For j = 3 To 8
   
4.         D.Add Cells(1, j).Value, j
   
5.     Next j
   
6.     For m = 1 To Worksheets.Count
   
7.         If Worksheets(m).Name <> "汇总" Then
   
8.             Arr = Worksheets(m).Range("A1").CurrentRegion.Value
   
9.             For j = 3 To UBound(Arr, 2)
   
10.                 Arr(1, j) = D(Arr(1, j))
    
11.             Next j
    
12.             For i = 2 To UBound(Arr)
    
13.                 S = Arr(i, 1) & Arr(i, 2)
    
14.                 If Not D.Exists(S) Then
    
15.                     k = k + 1: D.Add S, k
    
16.                     ReDim Preserve ArrR(1 To 8, 1 To k)
    
17.                     ArrR(1, k) = Arr(i, 1): ArrR(2, k) = Arr(i, 2)
    
18.                 End If
    
19.                 For j = 3 To UBound(Arr, 2)
    
20.                     ArrR(Arr(1, j), D(S)) = Arr(i, j)
    
21.                 Next j
    
22.             Next i
    
23.         End If
    
24.     Next m
    
25.     Range("a2:h" & Rows.Count).ClearContents
    
26.     Range("A2").Resize(k, 8) = Application.Transpose(ArrR)
    
27.     Range("A1").CurrentRegion.Sort Range("a1"), xlAscending, Header:=xlYes
    
28. End Sub

复制代码

看下附件是否为你所要的。

jmhwjd

liuguansky 发表于 2011-12-13 18:30
看下附件是否为你所要的。

谢谢！！！太感谢您了！！！！！！！！

jmhwjd

liuguansky 发表于 2011-12-13 18:30
看下附件是否为你所要的。

我测试过了！对我给你的电子表是很适用！！但没有适用于其他！我想说的是如果单位多几个，A、B、C……等小学用文字表示，就不行了！也就是说你的适用性不强，没有普遍性！