在线等～ 多表单多字段汇总

nico1321

各位大虾，
    需要系统自动生成汇总表，有各班级的成绩表单，但每班的科目不一样。 如何实现呢～  谢谢啦～

		语文	数学	物理	英语	化学		一班表单：
一班	A	60	61	62					语文	数学	物理
一班	B	70	71	72				A	60	61	62
一班	C	80	81	82				B	70	71	72
二班	AA		61	62	60			C	80	81	82
二班	BB		71	72	70			二班表单：
二班	CC		81	82	80
三班	AAA		61	62		60			英语	数学	物理
三班	BBB		71	72		70		AA	60	61	62
三班	CCC		81	82		80		BB	70	71	72
								CC	80	81	82
								三班表单：
									化学	数学	物理
								AAA	60	61	62
								BBB	70	71	72
								CCC	80	81	82

lsc900707

用字典+数组解决：

1. Sub gj23w98()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     For Each sht In Sheets
   
5.         If sht.Name <> ActiveSheet.Name Then
   
6.             arr = sht.[a1].CurrentRegion
   
7.             For i = 1 To UBound(arr, 2)
   
8.                 d(arr(1, i)) = 0
   
9.             Next
   
10.         End If
    
11.     Next
    
12.     ReDim brr(1 To 1000, 1 To d.Count + 1): m = 1
    
13.     For i = 1 To d.Count
    
14.         d(d.keys()(i - 1)) = i
    
15.         brr(1, i + 1) = d.keys()(i - 1)
    
16.     Next
    
17.     For Each sht In Sheets
    
18.         If sht.Name <> ActiveSheet.Name Then
    
19.             arr = sht.[a1].CurrentRegion
    
20.             For i = 2 To UBound(arr)
    
21.                 m = m + 1
    
22.                 brr(m, 1) = sht.Name
    
23.                 For j = 1 To UBound(arr, 2)
    
24.                     brr(m, d(arr(1, j)) + 1) = arr(i, j)
    
25.                 Next
    
26.             Next
    
27.         End If
    
28.     Next
    
29.     Cells.Clear
    
30.     [a1].Resize(m, UBound(brr, 2)) = brr
    
31.     [a1].Resize(m, UBound(brr, 2)).Borders.LineStyle = 1
    
32.     Application.ScreenUpdating = True
    
33. End Sub

复制代码

jjmysjg

字段不一致的多表合并

lrh788

收藏备用！！

不知道为什么

跟着版主学习，也练习下：

1. Sub 汇总()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Application.ScreenUpdating = False
   
4.     ReDim brr(1 To 1000, 1 To 100): x = 1: y = 2
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> ActiveSheet.Name Then
   
7.             arr = sht.[a1].CurrentRegion
   
8.             For i = 2 To UBound(arr, 2)
   
9.                 If Not d.exists(arr(1, i)) Then
   
10.                     y = y + 1
    
11.                     d(arr(1, i)) = y
    
12.                     brr(1, y) = arr(1, i)
    
13.                 End If
    
14.             Next
    
15.             For i = 2 To UBound(arr)
    
16.                 x = x + 1
    
17.                 brr(x, 1) = sht.Name: brr(x, 2) = arr(i, 1)
    
18.                 For j = 2 To UBound(arr, 2)
    
19.                     brr(x, d(arr(1, j))) = brr(x, d(arr(1, j))) + arr(i, j)
    
20.                 Next j
    
21.             Next i
    
22.         End If
    
23.     Next
    
24.     brr(1, 1) = "班级": brr(1, 2) = "姓名"
    
25.     With Sheets("汇总")
    
26.         .Cells.Clear
    
27.         .Cells(1, 1).Resize(x, y) = brr
    
28.         .Cells(1, 1).Resize(x).EntireRow.RowHeight = 18
    
29.         .Cells(1, 1).Resize(x, y).Borders.LineStyle = 9
    
30.     End With
    
31.     ActiveWindow.DisplayGridlines = fale
    
32.     Application.ScreenUpdating = True
    
33. End Sub

复制代码