如何用递归汇总文件夹及子文件夹下的所有文件，格式相同

lele400024 · 发表于 2017-1-4 17:37

请教各位大神，工作中，多次从软件导出表格，里面有很多子文件夹，汇总很不方便，也看了liulang0808的帖子，看到可以用字典进行汇总，但是我没有这个需求，只需要合并即可，改了几次代码也无法成功，还请高手赐教，谢谢大家附上他的代码参考
附件

万州区12个污水处理厂项目.rar (147.26 KB, 下载次数: 27)

五、汇总当前文件夹及子文件夹下所有excel文件内容
增加了红色字体部分
Public d
Sub 按钮1_Click()
Application.ScreenUpdating = False
ActiveSheet.UsedRange.ClearContents
Cells(1, 1) = "编号"
Cells(1, 2) = "数量"
Set d = CreateObject("scripting.dictionary")
Getfd (ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
Application.ScreenUpdating = True
If d.Count > 0 Then
ThisWorkbook.Sheets(1).[a2].Resize(d.Count) = WorksheetFunction.Transpose(d.keys)
ThisWorkbook.Sheets(1).[b2].Resize(d.Count) = WorksheetFunction.Transpose(d.items)
End If
d.RemoveAll
End Sub
Sub Getfd(ByVal pth)
Set Fso = CreateObject("scripting.filesystemobject")
Set ff = Fso.getfolder(pth)
For Each f In ff.Files
Rem 具体提取哪类文件，还是需要根据文件扩展名进行处理
If InStr(Split(f.Name, ".")(UBound(Split(f.Name, "."))), "xl") > 0 Then
If f.Name <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(f)
For Each sht In wb.Sheets
If WorksheetFunction.CountA(sht.UsedRange) > 1 Then
arr = sht.UsedRange
For j = 2 To UBound(arr)
d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)
Next j
End If
Next sht
wb.Close False
End If
End If
Next f
For Each fd In ff.subfolders
Getfd (fd)
Next fd
End Sub

复制代码

链接 http://club.excelhome.net/forum.php?mod=viewthread&tid=1165866&page=1&authorid=238368

182197315 · 发表于 2017-1-4 17:57

文件夹的级数不确定的话，可以用以下代码实现。
如果文件夹的级数固定，还可简化。

Sub 合并表格()
Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Application.ScreenUpdating = False
Dim arr(1 To 10000) As String
Dim f, cFile, i%, k%, x%
Dim wb As Workbook
arr(1) = ThisWorkbook.Path & "\"
i = 1: k = 1
Do While i < UBound(arr)
If arr(i) = "" Then Exit Do
f = Dir(arr(i), vbDirectory)
Do While f <> ""
      If InStr(f, ".") = 0 Then
         k = k + 1
         arr(k) = arr(i) & f & "\"
      End If
      f = Dir
Loop
i = i + 1
Loop

For x = 2 To UBound(arr)
If arr(x) = "" Then Exit For
cFile = Dir(arr(x) & "*.xls?")
Do While cFile <> ""
      Set wb = Workbooks.Open(arr(x) & cFile)
      With wb.Sheets("暂列金额")
         .Range("A1").CurrentRegion.Offset(1, 0).Copy Me.Range("A65536").End(3).Offset(1, 0)
      End With
      wb.Close
      cFile = Dir
Loop
Next x
Application.ScreenUpdating = True
End Sub

182197315 · 发表于 2017-1-4 18:00

下面是附件。

lele400024 · 发表于 2017-1-4 18:10

谢谢，回复好快，下来仔细学习哈原理

lele400024 · 发表于 2017-1-4 18:15

182197315 发表于 2017-1-4 18:00
下面是附件。

想引申两个问题
1.工作簿中不止一个工作表，名称不固定,如果不为空表，则合并。
2.汇总表不一定非要放到文件夹里面，能否自主选择需要汇总的文件夹目录

182197315 · 发表于 2017-1-4 18:56

Sub 合并表格()
Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Application.ScreenUpdating = False
Dim arr(1 To 10000) As String
Dim f, cFile, i%, k%, x%
Dim wb As Workbook
arr(1) = ThisWorkbook.Path & "\"
i = 1: k = 1
Do While i < UBound(arr)
If arr(i) = "" Then Exit Do
f = Dir(arr(i), vbDirectory)
Do While f <> ""
      If InStr(f, ".") = 0 Then
         k = k + 1
         arr(k) = arr(i) & f & "\"
      End If
      f = Dir
Loop
i = i + 1
Loop

For x = 2 To UBound(arr)
If arr(x) = "" Then Exit For
cFile = Dir(arr(x) & "*.xls?")
Do While cFile <> ""
      Set wb = Workbooks.Open(arr(x) & cFile)
      For Each sht In wb.Worksheets
         If WorksheetFunction.CountA(sht.UsedRange) <> 0 Then
            sht.Range("A1").CurrentRegion.Offset(1, 0).Copy Me.Range("A65536").End(3).Offset(1, 0)
         End If
      Next
      wb.Close
      cFile = Dir
Loop
Next x
Application.ScreenUpdating = True
End Sub

lele400024 · 发表于 2017-1-4 19:15

182197315 发表于 2017-1-4 18:56
Sub 合并表格()
Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Application.ScreenUpdating = F ...

第一个问题解决，第二个未解决，谢谢

lele400024 · 发表于 2017-1-4 19:42

182197315 发表于 2017-1-4 18:56
Sub 合并表格()
Range("A1").CurrentRegion.Offset(1, 0).ClearContents
Application.ScreenUpdating = F ...

修改了，供大家参考

Sub 合并表格()
Range("A1").CurrentRegion.Offset(1, 0).ClearContents
[color=Red]With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then
pathstr = .SelectedItems(1)
Else
Exit Sub
End If
End With[/color]
On Error Resume Next
'《《《《《《《《《《《《《《《《《《《《《《《《《《《《《《《《
Application.ScreenUpdating = False
Dim arr(1 To 10000) As String
Dim f, cFile, i%, k%, x%
Dim wb As Workbook
arr(1) = pathstr & ""
'arr(1) = ThisWorkbook.Path & ""
i = 1: k = 1
Do While i < UBound(arr)
If arr(i) = "" Then Exit Do
f = Dir(arr(i), vbDirectory)
Do While f <> ""
If InStr(f, ".") = 0 Then
k = k + 1
arr(k) = arr(i) & f & ""
End If
f = Dir
Loop
i = i + 1
Loop
For x = 2 To UBound(arr)
If arr(x) = "" Then Exit For
cFile = Dir(arr(x) & "*.xls?")
Do While cFile <> ""
Set wb = Workbooks.Open(arr(x) & cFile)
For Each sht In wb.Worksheets
If WorksheetFunction.CountA(sht.UsedRange) <> 0 Then
sht.Range("A1").CurrentRegion.Offset(1, 0).Copy Sheet1.Range("A65536").End(3).Offset(1, 0)
End If
Next
wb.Close
cFile = Dir
Loop
Next x
Application.ScreenUpdating = True
End Sub

复制代码

jjmysjg · 发表于 2017-1-5 06:50

留下记号，谢谢

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

[求助] 如何用递归汇总文件夹及子文件夹下的所有文件，格式相同

评分

评分

评分