求助多工作簿多工作表按工作表名称汇总

奥巴马学VBA

版主现在可以帮忙看看了吗。。?

蓝桥玄霜

1. Sub yy()
   
2.     Dim fso, folder, myPath$, Filename$, wb1 As Workbook, m&, Arr
   
3.     Dim Sht1 As Worksheet, i&, nm1$, wbnm$, sh As Worksheet, Myr&, Myc&
   
4.     Application.ScreenUpdating = False
   
5.     r = 0
   
6.     myPath = ThisWorkbook.Path & ""
   
7.     Set wb1 = ThisWorkbook
   
8.     a = InStr(wb1.Name, ".")
   
9.     wbnm = Left(wb1.Name, a - 1)
   
10.     Set fso = CreateObject("Scripting.FileSystemObject")
    
11.     Set folder = fso.GetFolder(myPath)
    
12.     strTmp = GetFileFolderList(folder)
    
13.     For i = 1 To r
    
14.         Filename = Arr1(i)
    
15.         nm1 = Split(Mid(Filename, InStrRev(Filename, "") + 1), ".")(0)
    
16.         If InStr(nm1, wbnm) Or Left(nm1, 1) = "$" Then GoTo 200
    
17.         Workbooks.Open Filename
    
18.         Dim wb As Workbook
    
19.         Set wb = ActiveWorkbook
    
20.         For Each sh In wb.Sheets
    
21.             Myr = sh.[b65536].End(xlUp).Row
    
22.             Myc = sh.[iv2].End(xlToLeft).Column
    
23.             nm = sh.Name
    
24.             If Myr > 2 Then
    
25.                 Arr = sh.Range("a3", sh.Cells(Myr, Myc))
    
26.                 With wb1.Sheets(nm)
    
27.                     m = .[b65536].End(xlUp).Row + 1
    
28.                     .Cells(m, 1).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
    
29.                 End With
    
30.             End If
    
31.         Next
    
32.         wb.Close savechanges:=False
    
33.         Set wb = Nothing
    
34. 200:
    
35.     Next
    
36.     Application.ScreenUpdating = True
    
37. End Sub
    

复制代码

奥巴马学VBA

感谢呀。。万分的感谢版主的耐心帮助。这次真的是全对了。。谢谢版主这几天对我的帖子关注。谢谢版主的耐心与热情帮助。有技术有耐心。而且从来不报怨我这个菜鸟的追问。{:soso_e177:}

zeropww

赞，虽然是很久以前的东西。。。

zyqn518

标记，学习学习

blackttea1

学习啦，谢谢哟