网页资讯视频图片知道文库贴吧地图采购
进入贴吧全吧搜索
excel吧 关注：281,535贴子：1,552,482
  • 5回复贴，共1页

求大神帮忙修改代码，支持汇总子文件夹

Sub 按钮1_Click()
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show Then mypath = .SelectedItems(1) Else Exit Sub
End With
If Right(mypath, 1) <> "\" Then mypath = mypath & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sh = ThisWorkbook.Sheets(1)
sh.UsedRange.Offset(1).ClearContents
r = 2
For Each f In sh.subfolders("scripting.filesystemobject").getfolder(mypath).Files
With Workbooks.Open(f)
.Sheets(1).UsedRange.Offset(2).Copy sh.Cells(r, 1)
r = sh.Cells(Rows.Count, 1).End(3).Row + 1
.Close False
End With
Next f
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
目前这个代码只能支持当前文件夹的汇总，可以修改成支持子文件夹吗


最好上个附件到百度网盘


2025-08-30 20:25:21
广告
不感兴趣
开通SVIP免广告
Option Explicit
Sub abc()
　Dim a, filename(), m, n, fso, i, j, k
　Set fso = CreateObject("scripting.filesystemobject")
　Call getfilename(fso, filename, n, ThisWorkbook.Path, ".xlsx")
　If n = 0 Then MsgBox "!": Exit Sub
　ReDim b(1 To 10 ^ 4, 1 To 12)
　For i = 1 To n
　　With GetObject(filename(i))
　　　With .ActiveSheet
　　　　a = .[a1].CurrentRegion.Resize(, 12).Value
　　　　For j = 3 To UBound(a)
　　　　　m = m + 1
　　　　　For k = 1 To UBound(a, 2)
　　　　　　b(m, k) = a(j, k)
　　　　　Next
　　　　Next
　　　End With
　　　.Close False
　　End With
　Next
　[a2].Resize(m + 10, UBound(b, 2)) = b
End Sub
Function getfilename(fso, filename, n, pth, mark)
　Dim spth, t
　If Right(pth, 1) <> "\" Then pth = pth & "\"
　　Set spth = fso.getfolder(pth)
　　For Each t In spth.Files
　　　If LCase(Right(t, Len(mark))) = LCase(mark) And InStr(t, "~") = 0 Then
　　　　n = n + 1: ReDim Preserve filename(1 To n)
　　　　filename(n) = spth & "\" & t.Name
　　　End If
　　Next
　　For Each t In spth.subfolders
　　　Call getfilename(fso, filename, n, t, mark)
　　Next
End Function


扫二维码下载贴吧客户端

下载贴吧APP
看高清直播、视频！
  • 5回复贴，共1页
分享到: