Loop Through Directory VBA to Copy Data With Format - vba

Question

I have few files in a directory or a folder and I want to copy a range (values with format to the current sheet). I have VBA code and I think it is not in order or something is missing in the code. Please help me to fix the issue.
(I have defined named range in each files in the directory. Is it is possible to copy using the named range?)
Copy from directory files given path & from sheet2 & paste it to file "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

One question remains:
(I have defined named range in each files in the directory. Is it is possible to copy using the named range?)
It's certainly possible. Thus assuming the Defined Name range is "DATA".
Just replace this line:
sourceWbk.Sheets("Sheet2").Range("A1:N24").Copy
with this:
sourceWbk.Sheets("Sheet2").Range("DATA").Copy
Actually, OP mentioned that this Names are generated by another procedure with the address "A1:N24". So in the case that the address is changed then there will be a need to update every other procedure that refers to it, instead by using the Defined Name don't have to worry about it as it will be taking care by design. That why it’s a good practice to use Defined Names.

Answer 2

I'd use this method:
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
This procedure is needed to get all the files in the folder:
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

Okay see if it works for you, had to add quite a bit
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