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

黄花菜

学习数组代码      

liuguansky

上传个不符的附件看看。

fjmxwrs

jmhwjd 发表于 2011-12-13 14:45
好的！但愿有高手能帮忙！

完成了，你可以增加数据和表格试下，学科也可以增加

1. Sub FuiZon()
   
2.     Dim d As Object, d1 As Object
   
3.     Dim Arr, i&, j&, j1&, k&, k1&, S$
   
4.     Dim iSheet As Worksheet
   
5.     k1 = 1
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Set d1 = CreateObject("scripting.dictionary")
   
8.     Application.ScreenUpdating = False
   
9.     Range("A1").CurrentRegion.ClearContents
   
10.     For Each iSheet In Worksheets
    
11.         If iSheet.Name <> "汇总" Then
    
12.             With iSheet
    
13.                 Arr = .UsedRange
    
14.             End With
    
15.             For j = 1 To UBound(Arr, 2)
    
16.                 If Not d.Exists(Arr(1, j)) Then
    
17.                     k = k + 1
    
18.                     d(Arr(1, j)) = k
    
19.                     Cells(1, d(Arr(1, j))) = Arr(1, j)
    
20.                 End If
    
21.             Next j
    
22.             For i = 2 To UBound(Arr)
    
23.                 S = Arr(i, 1) & Arr(i, 2)
    
24.                 If Not d1.Exists(S) Then
    
25.                     k1 = k1 + 1
    
26.                     d1(S) = k1
    
27.                     Cells(d1(S), 1) = Arr(i, 1)
    
28.                     Cells(d1(S), 2) = Arr(i, 2)
    
29.                     For j1 = 3 To UBound(Arr, 2)
    
30.                         Cells(d1(S), d(Arr(1, j1))) = Arr(i, j1)
    
31.                     Next j1
    
32.                 Else
    
33.                     For j1 = 3 To UBound(Arr, 2)
    
34.                         Cells(d1(S), d(Arr(1, j1))) = Arr(i, j1)
    
35.                     Next j1
    
36.                 End If
    
37.             Next i
    
38.             Erase Arr
    
39.         End If
    
40.     Next iSheet
    
41.     Range("A1").CurrentRegion.Sort Range("a1"), xlAscending, Header:=xlYes
    
42.     Application.ScreenUpdating = True
    
43. End Sub

复制代码

新建 Microsoft Excel 工作表 (2)(1).zip (14.51 KB, 下载次数: 7)

2011-12-14 14:54 上传

点击文件名下载附件

菜鸟锐

版主太强大了1！！！！！！！！！！！！

fjmxwrs

考虑到学习和姓名连在一起时有可能重复的问题（如表1的“西门小学“李一与“西门小”学李一）原代码会认为同一人同学校，代码修改如下：
新建 Microsoft Excel 工作表 (2)(1).zip (14.73 KB, 下载次数: 9)

2011-12-14 15:05 上传

点击文件名下载附件

jmhwjd

fjmxwrs 发表于 2011-12-14 14:53
完成了，你可以增加数据和表格试下，学科也可以增加

谢谢你了！！也辛苦你了！！！

jmhwjd

fjmxwrs 发表于 2011-12-14 15:05
考虑到学习和姓名连在一起时有可能重复的问题（如表1的“西门小学“李一与“西门小”学李一）原代码会认为同 ...

太感谢你了，无法用言语表达！！！！！！！！！！1