Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

你正在寻找更好的Excel学习教程吗?Excel技巧80集+数据透视表+函数初中高全套+VBA80集,想学的这儿全都有
查看: 154|回复: 3

[求助] 怎样汇总不同工作表数据

[复制链接]
发表于 2020-1-12 17:09 | 显示全部楼层 |阅读模式
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
2018秋和2019春两个表的人数不一样,顺序不一样,有重名的。有没有什么公式或者程序将2018秋和2019春汇总到汇总表1或者汇总表2中。

2018-2019教研活动汇总表.rar

10.96 KB, 下载次数: 12

发表于 2020-1-12 19:22 | 显示全部楼层
本帖最后由 hfwufanhf2006 于 2020-1-12 19:24 编辑

汇总表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公式,代码没有做任何修改,这个公式也建议保留,否则最后的总合计就没有数据了;
回复

使用道具 举报

发表于 2020-1-22 16:39 | 显示全部楼层
二合一
  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
复制代码
回复

使用道具 举报

发表于 2020-1-22 16:42 | 显示全部楼层
简化一点
  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
复制代码
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2020-1-25 12:16 , Processed in 0.046800 second(s), 4 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表