Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

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

[已解决] [已解决]多个工作表数据按条件汇总

[复制链接]
发表于 2017-6-3 13:56 | 显示全部楼层
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
1.是不是只有2个sheet  一个公司,一个内部
2.表格是不是都是按照月份统计的,会不会出现4月和5月混合在一张表里面的情况
回复 支持 反对

使用道具 举报

发表于 2017-6-3 14:11 | 显示全部楼层
网络人 发表于 2017-6-3 14:01
工作表不止2个可能有1-100多个,月份只会存在单月的

好的  明白了
回复 支持 反对

使用道具 举报

发表于 2017-6-3 15:05 | 显示全部楼层
本帖最后由 chart888 于 2017-6-3 15:11 编辑
  1. Private Sub CommandButton1_Click()

  2. Application.ScreenUpdating = False
  3. Application.DisplayAlerts = False

  4. Dim wt As Worksheet
  5. Dim i, i1, i2, r, AA As Integer
  6. Dim Arr
  7. Dim regex

  8. Set regex = CreateObject("vbscript.regexp")
  9. regex.Pattern = "\d+"
  10. AA = regex.Execute(Sheets("目录").Cells(1, 1).Value)(0) * 1
  11. Sheets("目录").Range("A3").Resize(10000, 15).ClearContents
  12. For Each wt In Worksheets
  13.     If wt.Name <> "目录" Then
  14.         r = wt.Range("A65536").End(xlUp).Row
  15.         wt.Cells(r, 5) = WorksheetFunction.Sum(wt.Range(Cells(4, 5).Address, Cells(r - 1, 5).Address))
  16.         wt.Cells(r, 6) = WorksheetFunction.Sum(wt.Range(Cells(4, 6).Address, Cells(r - 1, 6).Address))
  17.         For i1 = 4 To r - 1
  18.             wt.Cells(i1, 7) = wt.Cells(i1 - 1, 7) + wt.Cells(i1, 6) - wt.Cells(i1, 5)
  19.             wt.Cells(r, 7) = wt.Cells(r - 1, 7)
  20.         Next
  21.         BB = regex.Execute(wt.Cells(r, 1).Value)(0) * 1
  22.         i2 = Sheets("目录").Range("B65536").End(xlUp).Row + 1
  23.         If AA = BB Then
  24.             Sheets("目录").Cells(i2, 2) = wt.Name
  25.             Sheets("目录").Cells(i2, 3) = wt.Cells(r, 7)
  26.             Sheets("目录").Cells(i2, 7) = wt.Cells(r, 5)
  27.             Sheets("目录").Cells(i2, 11) = wt.Cells(r, 6)
  28.             Sheets("目录").Cells(i2, 15) = wt.Cells(3, 7)
  29.         Else
  30.             Sheets("目录").Cells(i2, 2) = wt.Name
  31.             Sheets("目录").Cells(i2, 3) = wt.Cells(r, 7)
  32.             Sheets("目录").Cells(i2, 15) = wt.Cells(3, 7)
  33.         End If
  34.     End If
  35. Next
  36. i2 = Sheets("目录").Range("B65536").End(xlUp).Row
  37. For i3 = 3 To i2
  38.     Sheets("目录").Cells(i3, 1) = i3 - 2
  39.     Sheets("目录").Cells(i3, 5) = i3 - 2
  40.     Sheets("目录").Cells(i3, 9) = i3 - 2
  41.     Sheets("目录").Cells(i3, 13) = i3 - 2
  42. Next
  43. Application.ScreenUpdating = True
  44. Application.DisplayAlerts = True
  45. End Sub
复制代码

工作簿2.zip

20.64 KB, 下载次数: 11

回复 支持 反对

使用道具 举报

发表于 2017-6-3 15:29 | 显示全部楼层    本楼为最佳答案   
网络人 发表于 2017-6-3 15:16
非常感谢!我什么时候能学到这样啊。还有一个超级链接的功能没有实现,就是点击”公司“”这个单元格的名 ...
  1. Private Sub CommandButton1_Click()

  2. Application.ScreenUpdating = False
  3. Application.DisplayAlerts = False

  4. Dim wt As Worksheet
  5. Dim i, i1, i2, r, AA As Integer
  6. Dim Arr
  7. Dim regex

  8. Set regex = CreateObject("vbscript.regexp")
  9. regex.Pattern = "\d+"
  10. AA = regex.Execute(Sheets("目录").Cells(1, 1).Value)(0) * 1
  11. Sheets("目录").Range("A3").Resize(10000, 15).Clear
  12. For Each wt In Worksheets
  13.     If wt.Name <> "目录" Then
  14.         r = wt.Range("A65536").End(xlUp).Row
  15.         wt.Cells(r, 5) = WorksheetFunction.Sum(wt.Range(Cells(4, 5).Address, Cells(r - 1, 5).Address))
  16.         wt.Cells(r, 6) = WorksheetFunction.Sum(wt.Range(Cells(4, 6).Address, Cells(r - 1, 6).Address))
  17.         For i1 = 4 To r - 1
  18.             wt.Cells(i1, 7) = wt.Cells(i1 - 1, 7) + wt.Cells(i1, 6) - wt.Cells(i1, 5)
  19.             wt.Cells(r, 7) = wt.Cells(r - 1, 7)
  20.         Next
  21.         BB = regex.Execute(wt.Cells(r, 1).Value)(0) * 1
  22.         i2 = Sheets("目录").Range("B65536").End(xlUp).Row + 1
  23.         If AA = BB Then
  24.             Sheets("目录").Cells(i2, 2) = wt.Name
  25.             Sheets("目录").Cells(i2, 3) = wt.Cells(r, 7)
  26.             Sheets("目录").Cells(i2, 7) = wt.Cells(r, 5)
  27.             Sheets("目录").Cells(i2, 11) = wt.Cells(r, 6)
  28.             Sheets("目录").Cells(i2, 15) = wt.Cells(3, 7)
  29.             ActiveSheet.Hyperlinks.Add Anchor:=Cells(i2, 2), Address:="", _
  30.             SubAddress:=wt.Name & "!A1", TextToDisplay:=Cells(i2, 2).Value
  31.         Else
  32.             Sheets("目录").Cells(i2, 2) = wt.Name
  33.             Sheets("目录").Cells(i2, 3) = wt.Cells(r, 7)
  34.             Sheets("目录").Cells(i2, 15) = wt.Cells(3, 7)
  35.             ActiveSheet.Hyperlinks.Add Anchor:=Cells(i2, 2), Address:="", _
  36.             SubAddress:=wt.Name & "!A1", TextToDisplay:=Cells(i2, 2).Value
  37.         End If
  38.     End If
  39. Next
  40. i2 = Sheets("目录").Range("B65536").End(xlUp).Row
  41. For i3 = 3 To i2
  42.     Sheets("目录").Cells(i3, 1) = i3 - 2
  43.     Sheets("目录").Cells(i3, 5) = i3 - 2
  44.     Sheets("目录").Cells(i3, 9) = i3 - 2
  45.     Sheets("目录").Cells(i3, 13) = i3 - 2
  46. Next
  47. Application.ScreenUpdating = True
  48. Application.DisplayAlerts = True
  49. End Sub
复制代码


工作簿2.zip

74.35 KB, 下载次数: 31

回复 支持 反对

使用道具 举报

发表于 2017-6-3 16:03 | 显示全部楼层

忘了跟你说怎么区分月份了
比如:
目录里面的   5月汇总表  就提取了里面的 5
内部里面的  4月汇总及余数  就提取了里面的4
如果两个是一样的就全部填充
如果不一样的就部分填充
回复 支持 反对

使用道具 举报

发表于 2017-6-5 12:54 | 显示全部楼层
本帖最后由 chart888 于 2017-6-5 12:57 编辑
网络人 发表于 2017-6-5 12:52
最下面能增加个汇总的行么

什么意思?
你把要求说详细点
最好能给我一个模拟的结果
你的这个目录我看的有点不伦不类
应该不是最终的吧
序列为什么要那么多
不是重复吗
回复 支持 反对

使用道具 举报

发表于 2017-6-5 13:15 | 显示全部楼层
本帖最后由 chart888 于 2017-6-5 13:28 编辑
  1. Private Sub CommandButton1_Click()

  2. Application.ScreenUpdating = False
  3. Application.DisplayAlerts = False

  4. Dim wt As Worksheet
  5. Dim i, i1, i2, r, AA, BB As Integer
  6. Dim Arr
  7. Dim regex

  8. Set regex = CreateObject("vbscript.regexp")
  9. regex.Pattern = "\d+"
  10. With Sheets("目录")
  11.     AA = regex.Execute(.Cells(1, 1).Value)(0) * 1
  12.     .Range("A3:O" & Rows.Count).ClearContents
  13.     For Each wt In Worksheets
  14.         If wt.Name <> "目录" Then
  15.             r = wt.Range("A65536").End(xlUp).Row
  16.             wt.Cells(r, 5) = WorksheetFunction.Sum(wt.Range(Cells(4, 5).Address, Cells(r - 1, 5).Address))
  17.             wt.Cells(r, 6) = WorksheetFunction.Sum(wt.Range(Cells(4, 6).Address, Cells(r - 1, 6).Address))
  18.             For i1 = 4 To r - 1
  19.                 wt.Cells(i1, 7) = wt.Cells(i1 - 1, 7) + wt.Cells(i1, 6) - wt.Cells(i1, 5)
  20.                 wt.Cells(r, 7) = wt.Cells(r - 1, 7)
  21.             Next
  22.             BB = regex.Execute(wt.Cells(r, 1).Value)(0) * 1
  23.             i2 = .Range("B65536").End(xlUp).Row + 1
  24.             If AA = BB Then
  25.                 .Cells(i2, 1) = i2 - 2
  26.                 .Cells(i2, 2) = wt.Name
  27.                 .Cells(i2, 3) = wt.Cells(r, 7)
  28.                 .Cells(i2, 5) = wt.Cells(r, 5)
  29.                 .Cells(i2, 6) = wt.Cells(r, 6)
  30.                 .Cells(i2, 7) = wt.Cells(3, 7)
  31.                 ActiveSheet.Hyperlinks.Add Anchor:=Cells(i2, 2), Address:="", _
  32.                 SubAddress:=wt.Name & "!A1", TextToDisplay:=Cells(i2, 2).Value
  33.             Else
  34.                 .Cells(i2, 1) = i2 - 2
  35.                 .Cells(i2, 2) = wt.Name
  36.                 .Cells(i2, 3) = wt.Cells(r, 7)
  37.                 .Cells(i2, 7) = wt.Cells(3, 7)
  38.                 ActiveSheet.Hyperlinks.Add Anchor:=Cells(i2, 2), Address:="", _
  39.                 SubAddress:=wt.Name & "!A1", TextToDisplay:=Cells(i2, 2).Value
  40.             End If
  41.         End If
  42.     Next
  43.     .Cells(i2 + 1, 1) = "合计"
  44.     .Cells(i2 + 1, 3) = WorksheetFunction.Sum(.Range(Cells(3, 3).Address, Cells(i2, 3).Address))
  45.     .Cells(i2 + 1, 5) = WorksheetFunction.Sum(.Range(Cells(3, 5).Address, Cells(i2, 5).Address))
  46.     .Cells(i2 + 1, 6) = WorksheetFunction.Sum(.Range(Cells(3, 6).Address, Cells(i2, 6).Address))
  47.     .Cells(i2 + 1, 7) = WorksheetFunction.Sum(.Range(Cells(3, 7).Address, Cells(i2, 7).Address))
  48.     .Range("A2:G2").EntireColumn.AutoFit
  49.     With .Range("A2").CurrentRegion.Borders
  50.         .LineStyle = xlContinuous
  51.         .Weight = xlThin
  52.     End With
  53.         With .Range("A2").Resize(i2, 7)
  54.             .VerticalAlignment = xlCenter
  55.             .HorizontalAlignment = xlCenter
  56.             .Font.Name = "微软雅黑"
  57.             .Font.Size = 11
  58.         End With
  59. End With

  60. Application.ScreenUpdating = True
  61. Application.DisplayAlerts = True
  62. End Sub
复制代码

工作簿2.zip

70.79 KB, 下载次数: 1

回复 支持 反对

使用道具 举报

发表于 2017-6-6 13:04 | 显示全部楼层
网络人 发表于 2017-6-6 12:52
  •             ActiveSheet.Hyperlinks.Add Anchor:=Cells(i2, 2), Address:="", _
  •             S ...

  • ActiveSheet.Hyperlinks.Add Anchor:=Cells(i2, 2), Address:="", _
                    SubAddress:=wt.Name & "!A1", TextToDisplay:=Cells(i2, 2).Value

    这句就是加超链接的
    Anchor:=Cells(i2, 2)   第2列加超链接
    TextToDisplay:=Cells(i2, 2).Value   超链接的文本为第2列的文本
    比如i2=3时  就是在第三行第2列加一个超链接,超链接的名字为第三行第2列内的文本

    回复 支持 反对

    使用道具 举报

    发表于 2017-6-6 13:39 | 显示全部楼层
    网络人 发表于 2017-6-6 13:31
    如果改成第3列修改那些

    你现在第三列不是有内容的?
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(i2, 3), Address:="", _
                    SubAddress:=wt.Name & "!A1", TextToDisplay:=Cells(i2, 2).Value

    回复 支持 反对

    使用道具 举报

    发表于 2017-6-6 15:11 | 显示全部楼层
    网络人 发表于 2017-6-6 15:08
    第三列和第二列互换位置
    1. Private Sub CommandButton1_Click()

    2. Application.ScreenUpdating = False
    3. Application.DisplayAlerts = False

    4. Dim wt As Worksheet
    5. Dim i, i1, i2, r, AA, BB As Integer
    6. Dim Arr
    7. Dim regex

    8. Set regex = CreateObject("vbscript.regexp")
    9. regex.Pattern = "\d+"
    10. With Sheets("目录")
    11.     AA = regex.Execute(.Cells(1, 1).Value)(0) * 1
    12.     .Range("A3:O" & Rows.Count).ClearContents
    13.     For Each wt In Worksheets
    14.         If wt.Name <> "目录" Then
    15.             r = wt.Range("A65536").End(xlUp).Row
    16.             wt.Cells(r, 5) = WorksheetFunction.Sum(wt.Range(Cells(4, 5).Address, Cells(r - 1, 5).Address))
    17.             wt.Cells(r, 6) = WorksheetFunction.Sum(wt.Range(Cells(4, 6).Address, Cells(r - 1, 6).Address))
    18.             For i1 = 4 To r - 1
    19.                 wt.Cells(i1, 7) = wt.Cells(i1 - 1, 7) + wt.Cells(i1, 6) - wt.Cells(i1, 5)
    20.                 wt.Cells(r, 7) = wt.Cells(r - 1, 7)
    21.             Next
    22.             BB = regex.Execute(wt.Cells(r, 1).Value)(0) * 1
    23.             i2 = .Range("B65536").End(xlUp).Row + 1
    24.             If AA = BB Then
    25.                 .Cells(i2, 1) = i2 - 2
    26.                 .Cells(i2, 3) = wt.Name
    27.                 .Cells(i2, 2) = wt.Cells(r, 7)
    28.                 .Cells(i2, 5) = wt.Cells(r, 5)
    29.                 .Cells(i2, 6) = wt.Cells(r, 6)
    30.                 .Cells(i2, 7) = wt.Cells(3, 7)
    31.                 ActiveSheet.Hyperlinks.Add Anchor:=Cells(i2, 3), Address:="", _
    32.                 SubAddress:=wt.Name & "!A1", TextToDisplay:=Cells(i2, 3).Value
    33.             Else
    34.                 .Cells(i2, 1) = i2 - 2
    35.                 .Cells(i2, 3) = wt.Name
    36.                 .Cells(i2, 2) = wt.Cells(r, 7)
    37.                 .Cells(i2, 7) = wt.Cells(3, 7)
    38.                 ActiveSheet.Hyperlinks.Add Anchor:=Cells(i2, 3), Address:="", _
    39.                 SubAddress:=wt.Name & "!A1", TextToDisplay:=Cells(i2, 3).Value
    40.             End If
    41.         End If
    42.     Next
    43.     .Cells(i2 + 1, 1) = "合计"
    44.     .Cells(i2 + 1, 3) = WorksheetFunction.Sum(.Range(Cells(3, 3).Address, Cells(i2, 3).Address))
    45.     .Cells(i2 + 1, 5) = WorksheetFunction.Sum(.Range(Cells(3, 5).Address, Cells(i2, 5).Address))
    46.     .Cells(i2 + 1, 6) = WorksheetFunction.Sum(.Range(Cells(3, 6).Address, Cells(i2, 6).Address))
    47.     .Cells(i2 + 1, 7) = WorksheetFunction.Sum(.Range(Cells(3, 7).Address, Cells(i2, 7).Address))
    48.     .Range("A2:G2").EntireColumn.AutoFit
    49.     With .Range("A2").CurrentRegion.Borders
    50.         .LineStyle = xlContinuous
    51.         .Weight = xlThin
    52.     End With
    53.         With .Range("A2").Resize(i2, 7)
    54.             .VerticalAlignment = xlCenter
    55.             .HorizontalAlignment = xlCenter
    56.             .Font.Name = "微软雅黑"
    57.             .Font.Size = 11
    58.         End With
    59. End With

    60. Application.ScreenUpdating = True
    61. Application.DisplayAlerts = True
    62. End Sub
    复制代码


    工作簿2.zip

    70.68 KB, 下载次数: 3

    回复 支持 反对

    使用道具 举报

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

    本版积分规则

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

    GMT+8, 2017-6-26 13:11 , Processed in 0.078000 second(s), 23 queries , Gzip On, Memcache On.

    Powered by Discuz! X3.2

    © 2001-2013 Comsenz Inc.

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