如何汇总一个文件夹下多个工作薄各工作表到汇总表的各工作表中

yzyyyyyyy · 发表于 2013-7-7 11:47

本帖最后由 yzyyyyyyy 于 2013-7-8 18:59 编辑

业绩库上交表格.rar (5.68 KB, 下载次数: 112) 文件夹中，含有多个工作薄，每个工作薄中有5个不同格式的工作表，如何将数据汇总到汇总工作薄相应的5个工作表中。
网上找到一个汇总第1个工作表的代码
Sub 按钮1_单击()
Dim myPath$, myFile$, AK As Workbook, aRow%
Application.ScreenUpdating = False       '冻结屏幕，以防屏幕抖动
myPath = ThisWorkbook.Path & "\"       '把文件路径定义给变量

myFile = Dir(myPath & "*.xls")          '依次找寻指定路径中的*.xls文件
If ThisWorkbook.Sheets(1).Range("a5") <> "" Then
If MsgBox("清除汇总表中原有记录吗？ ", 36, "提示") = 6 Then
      'Rows("5:1000").Clear


         ThisWorkbook.Sheets(1).Range("a5:l" & Cells.Rows.Count).ClearContents

End If
End If
Do While myFile <> ""                   '当指定路径中有文件时进行循环
   If myFile <> ThisWorkbook.Name Then
      Set AK = Workbooks.Open(myPath & myFile)       '打开符合要求的文件
      'For i = 1 To AK.Sheets.Count
      aRow = AK.Sheets(1).Range("a65536").End(xlUp).Row
      'tRow = ThisWorkbook.Sheets(1).Range("a65536").End(xlUp).Row + 1

         'Range("a5:f" & aRow)复制数据的行列
      AK.Sheets(1).Range("a5:f" & aRow).Copy ThisWorkbook.Sheets(1).[b65536].End(xlUp).Offset(1, -1)
      'Next

      Workbooks(myFile).Close False             '关闭源工作簿,并不作修改
   End If
   myFile = Dir                                  '找寻下一个*.xls文件
Loop

Application.ScreenUpdating = True                '冻结屏幕,此类语句一般成对使用
MsgBox "汇总完成，请查看！", 64, "提示"

End Sub

mps777 · 发表于 2013-7-7 12:07

如果都一样的格式的话，可以用SQL联合查询……当然最好用VBA，我不懂

yzyyyyyyy · 发表于 2013-7-7 18:15

请求帮助，，

yzyyyyyyy · 发表于 2013-7-7 19:31

再次请求帮助，

蓝桥玄霜 · 发表于 2013-7-7 20:49

只有一个工作表怎么汇总？

yzyyyyyyy · 发表于 2013-7-16 15:19

本帖最后由 yzyyyyyyy 于 2013-7-16 16:55 编辑

蓝桥玄霜发表于 2013-7-7 20:49
只有一个工作表怎么汇总？

如何汇总一个文件夹下多个工作薄各工作表到汇总表的各工作表中.rar (24.71 KB, 下载次数: 119)
上交的各工作薄，文件名为序号+姓名+身份证号，都有5个附件，格式一样,附件中已添加了例子。
1、汇总各工作表数据，
2、完成汇总表工作薄，统计表的统计数字。

zhaogang1960 · 发表于 2013-7-16 17:11

本帖最后由 zhaogang1960 于 2013-7-16 17:23 编辑

短信收到，5个工作表格式不同，有的12列，有的只有8列，且起始行也不同，所以需要对5个工作表分别处理

Sub Macro1()
Dim MyPath$, MyName$, sh As Worksheet, d As Object, arrsh, wb As Workbook, i&, t
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
arrsh = Array("A6:L15", "A4:H14", "A5:H15", "A5:J16", "A4:H14")
For i = 1 To Sheets.Count - 1
If InStr(Sheets(i).Name, "附件") Then
Sheets(i).Range(arrsh(i - 1)).Resize(1000).Clear
d(Sheets(i).Name) = i
End If
Next
Set wb = ThisWorkbook
MyPath = ThisWorkbook.Path & ""
MyName = Dir(MyPath & "*.xls")
Do While MyName <> ""
If MyName <> ThisWorkbook.Name Then
With GetObject(MyPath & MyName)
For Each sh In .Sheets
t = d(sh.Name)
If t <> "" Then sh.Range(arrsh(t - 1)).Copy wb.Sheets(t).[a65536].End(xlUp).Offset(1)
Next
.Close False
End With
End If
MyName = Dir
Loop
Application.ScreenUpdating = True
End Sub

复制代码

zhaogang1960 · 发表于 2013-7-16 17:12

本帖最后由 zhaogang1960 于 2013-7-16 17:23 编辑

请看附件

如何汇总一个文件夹下多个工作薄各工作表到汇总表的各工作表中.rar (28 KB, 下载次数: 584)

yzyyyyyyy · 发表于 2013-7-16 17:55

zhaogang1960 发表于 2013-7-16 17:12
请看附件

感谢zhaogang1960 版主的热心帮助，解决了一大难题。如何完成统计表中的各项数据的填写

zhaogang1960 · 发表于 2013-7-16 17:55

加上统计表计算:

Sub Macro1()
Dim MyPath$, MyName$, sh As Worksheet, d As Object, arrsh, wb As Workbook, i&, t, arr(1 To 1000, 1 To 11), m&, rng As Range
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
arrsh = Array("A6:L15", "A4:H14", "A5:H15", "A5:J16", "A4:H14")
For i = 1 To Sheets.Count - 1
If InStr(Sheets(i).Name, "附件") Then
Sheets(i).Range(arrsh(i - 1)).Resize(1000).Clear
d(Sheets(i).Name) = i
End If
Next
Set wb = ThisWorkbook
MyPath = ThisWorkbook.Path & ""
MyName = Dir(MyPath & "*.xls")
Do While MyName <> ""
If MyName <> ThisWorkbook.Name Then
m = m + 1
arr(m, 1) = m
arr(m, 2) = Replace(MyName, ".xls", "")
arr(m, 3) = Split(MyName, "-")(0)
arr(m, 4) = "姓名" & m
arr(m, 5) = Split(arr(m, 2), "-")(2)
With GetObject(MyPath & MyName)
For Each sh In .Sheets
t = d(sh.Name)
If t <> "" Then
Set rng = sh.Range(arrsh(t - 1))
r = sh.[b65536].End(xlUp).Row - rng.Row + 1
arr(m, 6) = arr(m, 6) + r
arr(m, t + 6) = arr(m, t + 6) + r
rng.Copy wb.Sheets(t).[a65536].End(xlUp).Offset(1)
End If
Next
.Close False
End With
End If
MyName = Dir
Loop
With Sheets("统计表")
.Range("A4:K65536").ClearContents
[a4].Resize(m, 11) = arr
.[f3:k3].FormulaR1C1 = "=SUM(R4C:R" & m + 3 & "C)"
End With
Application.ScreenUpdating = True
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 如何汇总一个文件夹下多个工作薄各工作表到汇总表的各工作表中

评分

评分