我的一个文件夹中有 3 个文件和一个主模板。
我想要:
- 循环浏览这些文件,然后将内容复制到主文件。
- 每个整个文件都将粘贴到主文件中的新工作表中。
- 新工作表的名称将与文件的名称相同。
下面的代码不起作用并且缺少功能 2 和 3。
Sub AllFiles()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim sh As Worksheet
folderPath = "C:\Users\Ryan\Desktop\LoopThroughFolders\Sample1\" 'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Filename = Dir(folderPath & "*.xlsx")
Do While Filename <> ""
Application.ScreenUpdating = False
Set wb = Workbooks.Open(folderPath & Filename)
Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Copy
'Not working well here as it will be overwritten by the next file
Workbooks("Master Template").Worksheets("Sheet1").Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial xlPasteValues
Workbooks(Filename).Close
Filename = Dir
Loop
Application.ScreenUpdating = True
End sub
尝试下面的代码(解释在代码注释中):
Option Explicit
Sub AllFiles()
Application.EnableCancelKey = xlDisabled
Dim folderPath As String
Dim Filename As String
Dim wb As Workbook
Dim Masterwb As Workbook
Dim sh As Worksheet
Dim NewSht As Worksheet
Dim FindRng As Range
Dim PasteRow As Long
' set master workbook
Set Masterwb = Workbooks("Master Template.xlsx")
folderPath = "C:\Users\Ryan\Desktop\LoopThroughFolders\Sample1\" 'contains folder path
If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
Application.ScreenUpdating = False
Filename = Dir(folderPath & "*.xls*")
Do While Filename <> ""
Set wb = Workbooks.Open(folderPath & Filename)
If Len(wb.Name) > 35 Then
MsgBox "Sheet's name can be up to 31 characters long, shorten the Excel file name"
wb.Close False
GoTo Exit_Loop
Else
' add a new sheet with the file's name (remove the extension)
Set NewSht = Masterwb.Worksheets.Add(After:=Masterwb.Worksheets(1))
NewSht.Name = Replace(wb.Name, ".xlsx", "")
End If
' loop through all sheets in opened wb
For Each sh In wb.Worksheets
' get the first empty row in the new sheet
Set FindRng = NewSht.Cells.Find(What:="*", Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not FindRng Is Nothing Then ' If find is successful
PasteRow = FindRng.Row + 1
Else ' find was unsuccessfull > new empty sheet, should paste at the first row
PasteRow = 1
End If
sh.UsedRange.Copy
NewSht.Range("A" & PasteRow).PasteSpecial xlPasteValues
Next sh
wb.Close False
Exit_Loop:
Set wb = Nothing
Filename = Dir
Loop
Application.ScreenUpdating = True
End Sub
本文内容由网友自发贡献,版权归原作者所有,本站不承担相应法律责任。如您发现有涉嫌抄袭侵权的内容,请联系:hwhale#tublm.com(使用前将#替换为@)