遍历目录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