循环目录VBA以格式复制数据

我有一个目录或文件夹中的几个文件，我想复制一个范围（格式值到当前工作表）。 我有VBA代码，我认为这是不是在顺序或代码中缺less的东西。 请帮我解决这个问题。

（我已经在目录中的每个文件中定义了命名范围，是否可以使用命名范围进行复制？）

从给定path的目录文件复制并从sheet2粘贴到文件“workbook.xlsm”Sheet“sheet1”

Sub LoopThroughDirectory() Dim MyFile As String Dim erow Dim Filepath As String Filepath = "C:\test" MyFile = Dir(Filepath) Do While Len(MyFile) > 0 If MyFile = "workbook.xlsm" Then Exit Sub End If Workbooks.Open (Filepath & MyFile) Sheets("Sheet2").Select Range("A1:N24").Copy Workbooks.Open ("Filepath & workbook.xlsm") If Sheets("Sheet1").Range("A1") = vbNullString Then Sheets("Sheet1").Range ("A1:N24") Selection.PasteSpecial Paste:=xlPasteFormats Selection.PasteSpecial Paste:=xlPasteValues Else Selection.Copy Sheets("sheet1").Cells(A1, Columns.Count).End(xlToLeft).Offset(0, 1) End If MyFile = Dir Loop End Sub 

Answer 1

还有一个问题：

（我已经在目录中的每个文件中定义了命名范围，是否可以使用命名范围进行复制？）

这当然是可能的。 因此，假设Defined Name范围是"DATA" 。 只需更换这一行：

 sourceWbk.Sheets("Sheet2").Range("A1:N24").Copy 

有了这个：

 sourceWbk.Sheets("Sheet2").Range("DATA").Copy 

实际上，OP提到这个Names是由地址为"A1:N24"另一个程序生成的。 所以在地址被改变的情况下，将需要更新引用它的所有其他过程，而不是使用“ Defined Name不必担心，因为它将通过devise来保持谨慎。 那为什么使用Defined Names是个好习惯。

Answer 2

我会用这个方法：

 Sub LoopThroughDirectory() Dim MyFile As String Dim FilePath As String Dim colFiles As Collection Dim vFile As Variant Dim wrkbkSource As Workbook Dim wrkbkTarget As Workbook Dim rngTarget As Range FilePath = "C:\test\" MyFile = "workbook.xlsm" Set colFiles = New Collection EnumerateFiles FilePath, "*.xlsm", colFiles Set wrkbkTarget = Workbooks.Open(FilePath & MyFile) For Each vFile In colFiles If vFile <> FilePath & MyFile Then Set wrkbkSource = Workbooks.Open(vFile, False) wrkbkSource.Worksheets(1).Range("A1:N24").Copy Set rngTarget = wrkbkTarget.Worksheets("Sheet1").Cells(1, wrkbkTarget.Worksheets("Sheet1").Columns.Count).End(xlToLeft) rngTarget.PasteSpecial xlPasteFormats rngTarget.PasteSpecial xlPasteValues wrkbkSource.Close False End If Next vFile End Sub 

需要执行此过程才能获取文件夹中的所有文件：

 Sub EnumerateFiles(ByVal sDirectory As String, _ ByVal sFileSpec As String, _ ByRef cCollection As Collection) Dim sTemp As String sTemp = Dir$(sDirectory & sFileSpec) Do While Len(sTemp) > 0 cCollection.Add sDirectory & sTemp sTemp = Dir$ Loop End Sub 

Answer 3

好吧，看看它是否适合你，不得不增加一点

 Sub LoopThroughDirectory() Dim MyFile As String Dim erow Dim Filepath As String Dim targetWbk As Workbook Dim sourceWbk As Workbook Filepath = "C:\test" MyFile = Dir(Filepath) Workbooks.Open (Filepath & "\workbook.xlsm") Set sourceWbk = ActiveWorkbook Do While Len(MyFile) > 0 If Not MyFile = "workbook.xlsm" And MyFile = "*.xls*" Then Workbooks.Open (Filepath & MyFile) Set sourceWbk = ActiveWorkbook sourceWbk.Sheets("Sheet2").Range("A1:N24").Copy If targetWbk.Sheets("Sheet1").Range("A1") = vbNullString Then targetWbk.Sheets("Sheet1").Range("A1:N24").PasteSpecial xlPasteFormulas, xlPasteValues Else targetWbk.Sheets("sheet1").Cells(A1, Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteFormulas, xlPasteValues End If MyFile = Dir End If Loop End Sub