Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 7177|回复: 11

多个相同格式工作薄汇总到同一个工作薄不同工作表内

[复制链接]
发表于 2016-5-6 16:32 | 显示全部楼层 |阅读模式
附件"TTL汇总.xls"为总表格式,内有7张工作表,分别需要提取其他相同格式工作簿同一工作表内的数据并对应汇总起来。目前的操作方式是选中后用选择性粘贴转置,因为工作薄及内容太多,工作量太大,所以希望能用VBA来实现,还望有人能帮忙解决,谢谢~~~

销售.zip

92.44 KB, 下载次数: 36

发表于 2016-5-6 17:52 | 显示全部楼层
Sub test()
    Dim p, f, A(), r%, i%, path$, area$
    Application.ScreenUpdating = False

    '1)生成参数1
    p = ThisWorkbook.path & "\"
    f = Dir(p)
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            i = i + 1
            ReDim Preserve A(1 To i)

            With Workbooks.Open(p & f)
                If r = 0 Then r = Range("a65536").End(xlUp).Row - 1
                path = "'" & ThisWorkbook.path & "\[" & f & "]"
                area = "'!R2C1:R" & r & "C7"
                A(i) = path & Sheets(1).Name & area
                .Close False
            End With
        End If
        f = Dir
    Loop

    '2)执行合并计算
    With ThisWorkbook.Sheets("数据源").Range("a1")
        .CurrentRegion.ClearContents
        .Consolidate Sources:=A, Function:=xlSum, TopRow:=True, LeftColumn:=True
    End With
End Sub

销售2.rar (90.47 KB, 下载次数: 36)
回复

使用道具 举报

发表于 2016-5-6 20:55 | 显示全部楼层
本帖最后由 lichuanboy44 于 2016-5-6 21:25 编辑

     跨工作簿导入汇总,我较熟悉,可能是这样吧。本程序正确运行的前提是销售总额至销售笔数这6个表的结构完全一模一样,保证每个店都在各表的同一行,减轻程序编制难度。
     注:再次编辑,并人为加了两个店的副本,以便程序进行错误识别。
  1. Sub test2()
  2.     Dim p%, f, a, r%, i%, path, n%, cr
  3.     Application.ScreenUpdating = False
  4.     On Error Resume Next
  5.     tb = Timer
  6.     Set d = CreateObject("scripting.dictionary")
  7.     '1、将本簿“销售总额”表的B列的店名所在行数存入字典中,以便写入数据时用
  8.     '其它表店名顺序和所在行数必须和“销售总额”一致,否则自己修改。
  9.     n = Worksheets(1).[B65536].End(3).Row
  10.     ar = Worksheets(1).Range("B4:B" & n)
  11.     c = 1: ReDim cr(1 To c)    'cr数组专用于存放TTL汇总店名中没有的店(工作簿),以便提醒
  12.     Worksheets(7).[A2:AH2000].ClearContents
  13.     For i = 1 To n - 3
  14.         a = ar(i, 1)
  15.         If a <> "" And Not a Like "*小计*" And Not a Like "*合计*" And Not a Like "*累计*" Then
  16.             d(a) = i + 3
  17.         End If
  18.     Next
  19.     '2)依次打开工作簿,读取每表B3:G33固定区域的数据
  20.     path = ThisWorkbook.path & ""
  21.     f = Dir(path & "*.xls*")
  22.     Do While f <> ""
  23.         If f <> ThisWorkbook.Name Then
  24.             With Workbooks.Open(path & f)
  25.                 br = .Worksheets(1).[B3:G33]
  26.                 wn = .Name
  27.                 .Close False
  28.             End With
  29.             wn2 = Left(wn, InStr(wn, ".xls") - 1)
  30.             If d.exists(wn2) Then
  31.                 r = d(wn2)    '写入的第几行
  32.             Else
  33.                 ReDim Preserve cr(1 To c)
  34.                 cr(c) = wn2
  35.                 'MsgBox "汇总表中无" & wn2 & "工作簿,请审核"
  36.                 c = c + 1
  37.             End If
  38.             For i = 1 To 6
  39.                 Worksheets(i).Range("C" & r).Resize(1, 31) = _
  40.                 WorksheetFunction.Transpose(WorksheetFunction.Index(br, 0, i))
  41.             Next
  42.             With Worksheets(7)
  43.                 nn = .[B65536].End(3).Row: If nn = 0 Then nn = 1
  44.                 .Range("B" & nn + 1).Resize(6, 31) = WorksheetFunction.Transpose(br)
  45.                 .Range("A" & nn + 1 & ":A" & nn + 6) = wn2
  46.             End With
  47.             p = p + 1
  48.         End If
  49.         f = Dir
  50.     Loop
  51.     With Worksheets(1)   '将TTL汇总店名中没有的店,写入“销售总额”表的最后,以便提醒。
  52.       .Range("B" & n + 2).Resize(300, 1).ClearContents
  53.       .Range("B" & n + 2) = "以下店的数据未导入:"
  54.       .Range("B" & n + 3).Resize(UBound(cr), 1) = WorksheetFunction.Transpose(cr)
  55.     End With
  56.     tn = Timer - tb
  57.     [D1] = Format(tn, "0.00秒")
  58.     Application.ScreenUpdating = True
  59.     MsgBox "本次运行耗时" & Format(tn, "0.00秒") & "/共成功导入" & p - c + 1 & "个店(工作簿)的数据" & vbCrLf & _
  60.            "提醒:有" & c - 1 & "个店数据未导入,具体情况请在“销售总额”表尾查看"
  61.      Worksheets(1).Activate
  62.      Worksheets(1).Range("B" & n + 2).Select
  63. End Sub
复制代码

销售3.zip

107.02 KB, 下载次数: 58

回复

使用道具 举报

发表于 2016-5-6 20:57 | 显示全部楼层
奇怪,每次上传代码,都在$符号后胡乱添加了多余的$符号,上述程序代码复制后注意删除多余的$符号,在此提示。
回复

使用道具 举报

 楼主| 发表于 2016-5-9 09:12 | 显示全部楼层
lichuanboy44 发表于 2016-5-6 20:55
跨工作簿导入汇总,我较熟悉,可能是这样吧。本程序正确运行的前提是销售总额至销售笔数这6个表的结构 ...

完美解决了我的问题,非常感谢~~~
回复

使用道具 举报

 楼主| 发表于 2016-5-9 09:18 | 显示全部楼层
爱疯 发表于 2016-5-6 17:52
Sub test()
    Dim p, f, A(), r%, i%, path$, area$
    Application.ScreenUpdating = False

试了一下,只有汇总表,没有分配到对应的工作表,这个问题已经解决,但还是非常感谢~~~
回复

使用道具 举报

发表于 2019-1-7 11:19 | 显示全部楼层
大神 太厉害了  请问我只想把很多相同套表里面的数据汇总到一个套表里 怎么办呀
回复

使用道具 举报

发表于 2019-1-7 18:26 | 显示全部楼层
yibenwanli123 发表于 2019-1-7 11:19
大神 太厉害了  请问我只想把很多相同套表里面的数据汇总到一个套表里 怎么办呀

建议单独开新帖,说明需求,并上传附件
回复

使用道具 举报

匿名  发表于 2019-7-14 11:06
大神 太厉害了 请问我想把很多不工作薄中不同的工作表里面的数据汇总到一个总表里
条件:
1.不同的工作表的第1行为表格名称,第2行为表格的列标题
2.不同的工作表的A2为"姓名"标题,A2以下为不同的名字
目的:
1.总表的第1行存放总表的名称
2.总表的第2行依次存放不同的工作表的第1行表格名称
3.总表和第3行依次存放不同的工作表的第2行表格的列标题
3.总表a4以下为不同的名字
4.根据"姓名"依次存放,列标题为"姓名"的只能一列,名字不重复,总表的第3行依次存放不同的工作表的第2行表格的列标题(可重复),相应的数据对应存放.
怎么办呀
回复

使用道具

匿名  发表于 2019-7-14 11:30
大神 太厉害了 请问我想把很多不工作薄中不同的工作表里面的数据汇总到一个总表里
条件:
1.不同的工作表的第1行为表格名称,第2行为表格的列标题
2.不同的工作表的A2为"姓名"标题,A2以下为不同的名字
目的:
1.总表的第1行存放总表的名称
2.总表的第2行依次存放不同的工作表的第1行表格名称
3.总表和第3行依次存放不同的工作表的第2行表格的列标题
3.总表a4以下为不同的名字
4.根据"姓名"依次存放,列标题为"姓名"的只能一列,名字不重复,总表的第3行依次存放不同的工作表的第2行表格的列标题(可重复),相应的数据对应存放.
怎么办呀

合并工作薄.zip

19.99 KB, 下载次数: 102

回复

使用道具

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

本版积分规则

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

GMT+8, 2024-3-28 23:17 , Processed in 0.609463 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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