怎样汇总不同工作表数据

飞起一脚

2018秋和2019春两个表的人数不一样，顺序不一样，有重名的。有没有什么公式或者程序将2018秋和2019春汇总到汇总表1或者汇总表2中。

hfwufanhf2006

汇总表1的代码，放在工作表“汇总表1”中执行：

If [b10000].End(3).Row >= 4 Then
   Range(Cells(4, 1), Cells([b10000].End(3).Row, 5)).ClearContents
End If
Dim arr
js = 0
hs = 4
For i = 4 To Worksheets("2018秋").[b1000].End(3).Row
    s1 = Worksheets("2018秋").Cells(i, 2)
    bz = False
    For k = 1 To js
        If arr(k) = s1 Then
           bz = True
           Exit For
        End If
    Next k
    If Not bz Then
       js = js + 1
       If js = 1 Then
          ReDim arr(1)
       Else
          ReDim Preserve arr(js)
       End If
       arr(js) = s1
       Cells(hs, 1) = hs
       Cells(hs, 2) = s1
       Cells(hs, 3) = Worksheets("2018秋").Cells(i, 6)
       hs = hs + 1
    Else
       Cells(k + 3, 3) = Worksheets("2018秋").Cells(i, 6)
    End If
Next i
For i = 4 To Worksheets("2019春").[b1000].End(3).Row
    s1 = Worksheets("2019春").Cells(i, 2)
    bz = False
    For k = 1 To js
        If arr(k) = s1 Then
           bz = True
           Exit For
        End If
    Next k
    If Not bz Then
       js = js + 1
       If js = 1 Then
          ReDim arr(1)
       Else
          ReDim Preserve arr(js)
       End If
       arr(js) = s1
       Cells(hs, 1) = hs
       Cells(hs, 2) = s1
       Cells(hs, 4) = Worksheets("2019春").Cells(i, 6)
       hs = hs + 1
    Else
       Cells(k + 3, 4) = Worksheets("2019春").Cells(i, 6)
    End If
Next i
For i = 4 To [b10000].End(3).Row
    Cells(i, 5) = Cells(i, 3) + Cells(i, 4)
Next i


汇总表2的代码，需要放在工作表“汇总表2”中执行：

If [b10000].End(3).Row >= 4 Then
   Range(Cells(4, 1), Cells([b10000].End(3).Row, 6)).ClearContents
End If
Dim arr
js = 0
hs = 4
For i = 4 To Worksheets("2018秋").[b1000].End(3).Row
    s1 = Worksheets("2018秋").Cells(i, 2)
    bz = False
    For k = 1 To js
        If arr(k) = s1 Then
           bz = True
           Exit For
        End If
    Next k
    If Not bz Then
       js = js + 1
       If js = 1 Then
          ReDim arr(1)
       Else
          ReDim Preserve arr(js)
       End If
       arr(js) = s1
       Cells(hs, 1) = hs
       Cells(hs, 2) = s1
       Cells(hs, 3) = Worksheets("2018秋").Cells(i, 3)
       Cells(hs, 4) = Worksheets("2018秋").Cells(i, 4)
       Cells(hs, 5) = Worksheets("2018秋").Cells(i, 5)
       hs = hs + 1
    Else
       Cells(k + 3, 3) = Worksheets("2018秋").Cells(i, 3)
       Cells(k + 3, 4) = Worksheets("2018秋").Cells(i, 4)
       Cells(k + 3, 5) = Worksheets("2018秋").Cells(i, 5)
    End If
Next i
For i = 4 To Worksheets("2019春").[b1000].End(3).Row
    s1 = Worksheets("2019春").Cells(i, 2)
    bz = False
    For k = 1 To js
        If arr(k) = s1 Then
           bz = True
           Exit For
        End If
    Next k
    If Not bz Then
       js = js + 1
       If js = 1 Then
          ReDim arr(1)
       Else
          ReDim Preserve arr(js)
       End If
       arr(js) = s1
       Cells(hs, 1) = hs
       Cells(hs, 2) = s1
       Cells(hs, 3) = Worksheets("2019春").Cells(i, 3)
       Cells(hs, 4) = Worksheets("2019春").Cells(i, 4)
       Cells(hs, 5) = Worksheets("2019春").Cells(i, 5)
       hs = hs + 1
    Else
       Cells(k + 3, 3) = Cells(k + 3, 3) + Worksheets("2019春").Cells(i, 3)
       Cells(k + 3, 4) = Cells(k + 3, 4) + Worksheets("2019春").Cells(i, 4)
       Cells(k + 3, 5) = Cells(k + 3, 5) + Worksheets("2019春").Cells(i, 5)
    End If
Next i
For i = 4 To [b10000].End(3).Row
    Cells(i, 6) = Cells(i, 3) + Cells(i, 4) + Cells(i, 5)
Next i


1、这两个表的汇总很相似，结构都是一样的，只有个别细节有修改；

2、两个汇总表的最后合计使用了合并单元格，这个需要特别注意。代码没有对合并单元格做处理，在汇总前需要确保汇总的行数是足够用的，否则会发生错误，因为代码是不能对合并单元格写入数据的。作为建议，我建议删掉合并单元格，没有合并单元格并不影响美观；
3、最后的合计行以及其中的sum公式，代码没有做任何修改，这个公式也建议保留，否则最后的总合计就没有数据了；

grf1973

二合一

1. Sub 统计()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Dim brr(1 To 10000, 4)
   
4.     Dim crr(1 To 10000, 5)
   
5.     For sht = 3 To 4
   
6.         arr = Sheets(sht).Range("a4:f" & Sheets(sht).[a65536].End(3).Row - 1)
   
7.         For i = 1 To UBound(arr)
   
8.             x = arr(i, 2)
   
9.             If Not d.exists(x) Then
   
10.                 n = n + 1
    
11.                 brr(n, 0) = n
    
12.                 brr(n, 1) = x
    
13.                 brr(n, sht - 1) = arr(i, 6)
    
14.                 brr(n, 4) = arr(i, 6)
    
15.                 crr(n, 0) = n
    
16.                 For j = 1 To 5
    
17.                     crr(n, j) = arr(i, j + 1)
    
18.                 Next
    
19.                 d(x) = n
    
20.             Else
    
21.                 p = d(x)
    
22.                 brr(p, sht - 1) = arr(i, 6)
    
23.                 brr(p, 4) = brr(p, 4) + arr(i, 6)
    
24.                 For j = 2 To 5
    
25.                     crr(p, j) = crr(p, j) + arr(i, j + 1)
    
26.                 Next
    
27.             End If
    
28.         Next
    
29.     Next
    
30.     Sheets(1).[a4:e10000] = ""
    
31.     Sheets(1).[a4].Resize(n, 5) = brr
    
32.     Sheets(2).[a4:e10000] = ""
    
33.     Sheets(2).[a4].Resize(n, 6) = crr
    
34. End Sub

复制代码

grf1973

简化一点

1. Sub 统计()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Dim brr(1 To 10000, 4)
   
4.     Dim crr(1 To 10000, 5)
   
5.     For sht = 3 To 4
   
6.         arr = Sheets(sht).Range("a4:f" & Sheets(sht).[a65536].End(3).Row - 1)
   
7.         For i = 1 To UBound(arr)
   
8.             x = arr(i, 2)
   
9.             If Not d.exists(x) Then
   
10.                 n = n + 1
    
11.                 brr(n, 0) = n
    
12.                 brr(n, 1) = x
    
13.                 crr(n, 0) = n
    
14.                 crr(n, 1) = x
    
15.                 d(x) = n
    
16.             End If
    
17.             p = d(x)
    
18.             brr(p, sht - 1) = arr(i, 6)
    
19.             brr(p, 4) = brr(p, 4) + arr(i, 6)
    
20.             For j = 2 To 5
    
21.                 crr(p, j) = crr(p, j) + arr(i, j + 1)
    
22.             Next
    
23.         Next
    
24.     Next
    
25.     Sheets(1).[a4:e10000] = ""
    
26.     Sheets(1).[a4].Resize(n, 5) = brr
    
27.     Sheets(2).[a4:e10000] = ""
    
28.     Sheets(2).[a4].Resize(n, 6) = crr
    
29. End Sub

复制代码

kszcs

留个记号。谢谢大师