关于合并工作簿

officeluna

每天由门店发email给我表格，我要将这些表格汇总到一张总表里，可是门店又很多，要十几家，所以想哪位高手可以帮我如何用宏汇总到一张表格里面，谢谢！详细见附件

无聊的疯子

删除文件的代码你需要删除就启用,不需要删除就不启用

1. 
   
2. Sub cc()
   
3. Dim App As New Excel.Application, Bk As Workbook
   
4. Dim Pat As String, Nm As String, Sh As Worksheet
   
5. Dim Hx As Long, Rng As Range, Arr()
   
6.   
   
7.   App.Visible = True          '不显示 Excel 程序
   
8.   App.AutomationSecurity = 2  '禁用宏
   
9.   Set Sh = Sheets("Sheet1")   '指定 汇总 的工作表
   
10.   Pat = ThisWorkbook.Path & ""   '提取路径
    
11.   Nm = Dir(Pat & "*.xls")     '提取文件 名称
    
12.   Do
    
13.     If Not (Nm Like "*汇总*") Then    '如果 文件名中没有 汇总
    
14.       Set Rng = Sh.Range("B65536").End(xlUp).Offset(1)
    
15.       Set Bk = App.Workbooks.Open(Pat & Nm, , True) '以只读方式打开文件
    
16.       With Bk.Sheets(1)   '指定第一个工作表
    
17.         Hx = .Range("A65536").End(xlUp).Row   '提取数据使用的最大行数
    
18.         Arr = .Range("A3:D" & Hx).Value       '提取数据
    
19.         Rng.Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr   '数据 写入
    
20.         Rng.Offset(, -1).Value = Split(Nm, ".")(0)  '写入店名
    
21.       End With
    
22.       Bk.Close False    '关闭文件,并不保存
    
23.       'Kill Pat & Nm    '删除文件
    
24.     End If
    
25.     Nm = Dir()    '读取 下一个文件
    
26.   Loop Until Len(Nm) = 0    '如果文件读取完,则退出 do 循环
    
27.   App.Quit      '退出 Excel 程序
    
28. End Sub
    

复制代码

officeluna

无法用呢，请说明详细一点，

无聊的疯子

officeluna 发表于 2013-4-22 22:03
无法用呢，请说明详细一点，

打开你的汇总工作薄,把代码Copy进去,运行一下就行了

hoogle

1. Sub hoogle()
   
2. Dim i, DataName
   
3. Sheet1.Range("a3", Cells(Range("b65536").End(3).Row, "e")).ClearContents
   
4. Sheet1.Range("a2").ClearContents
   
5. DataName = Dir(ThisWorkbook.Path & "")
   
6. Do While DataName <> ""
   
7.     If DataName <> "汇总.xls" Then
   
8.         Workbooks.Open (ThisWorkbook.Path & "" & DataName)
   
9.             With ActiveWorkbook.Sheets("sheet1")
   
10.                 .Range("a3", .Range("d65536").End(3)).Copy
    
11.                 ActiveWorkbook.Close SaveChanges:=False
    
12.             End With
    
13.         ThisWorkbook.Sheets("Sheet1").Range("b65536").End(3).Offset(1, -1) = Split(DataName, ".")(0)
    
14.         ThisWorkbook.Sheets("Sheet1").Range("b65536").End(3).Offset(1, 0).Select
    
15.         ActiveSheet.Paste
    
16.     End If
    
17.     DataName = Dir
    
18. Loop
    
19. End Sub
    

复制代码

hoogle

所有文件放入这个文件夹.rar (17.22 KB, 下载次数: 64)

2013-4-22 22:29 上传

点击文件名下载附件

0Mouse

用这个工具可以轻松解决！
演示：（单击图片可以放大观看）

小千办公

工具附件： 多簿单表数据合并专家1.0.rar (67.37 KB, 下载次数: 94)

2013-11-10 10:18 上传

点击文件名下载附件