VBA遍历文件夹中的文件并复制/粘贴到主文件 [英] VBA Loop through files in folder and copy/paste to master file
本文介绍了VBA遍历文件夹中的文件并复制/粘贴到主文件的处理方法,对大家解决问题具有一定的参考价值,需要的朋友们下面随着小编来一起学习吧!
问题描述
我正在一个项目中,该项目在一个文件夹中有3个文件,并且有一个主模板.这是我想做的:
I'm working on a project that has 3 files in a folder and one master template. Here is what I want to do:
- 自动循环浏览这些文件,然后复制内容并将其粘贴到主文件中.
- 每个WHOLE文件都将粘贴到主文件中的新工作表中.
- 新工作表的名称将与文件名相同.
我试图编写一些代码,但是我对VBA没有经验.以下代码无法正常工作,并且缺少功能2和3.请提供帮助!
I tried to write some codes but I'm not experienced on VBA. The codes below are not working properly and missing functions 2 and 3. Please help!
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
推荐答案
尝试下面的代码(解释在代码注释中):
Try the code below (explanations are inside the code comments):
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
这篇关于VBA遍历文件夹中的文件并复制/粘贴到主文件的文章就介绍到这了,希望我们推荐的答案对大家有所帮助,也希望大家多多支持IT屋!
查看全文