Home » excel » vba – Copying columns from multiple excel files and pasting into one master file

vba – Copying columns from multiple excel files and pasting into one master file

Posted by: admin April 23, 2020 Leave a comment

Questions:

I want to copy one column (always the same one – B3:B603) from multiple excel files and paste those columns to one file, so I can combine all data in one place. My macro successfully searches for, and pastes this column of data into an empty column (which is C3 in my master file).

When I have more than one column to paste, my macro pastes new columns always in the same position (C3), so overwrites the previous data. How to make the macro to recognise that the next column should be pasted always to the next empty column (so D3, then E3 etc.).

I know similar problems were discussed already, but I am an amatour in programming and I couldn’t solve it based on the previous answers.

My current code is:

Sub LoopThroughDirectory()
Dim MyFile As String
Dim Filepath As String
Filepath = "D:\DATA\"
MyFile = Dir(Filepath)


Do While Len(MyFile) > 0
    If MyFile = "zmaster.xlsm" Then
    Exit Sub
    End If

    Workbooks.Open (Filepath & MyFile)
    Range("B3:B603").Copy
    Application.DisplayAlerts = False
    ActiveWorkbook.Close

ActiveSheet.Paste destination:=Worksheets("Sheet1").Range("B3:B603")

    MyFile = Dir
Loop
End Sub
How to&Answers:

To paste to the next column each time, you could simply use a counter like this:

Sub LoopThroughDirectory()
    Dim MyFile                As String
    Dim Filepath              As String
    Dim lNextColumn           As Long
    Dim wsPaste               As Worksheet

    Filepath = "D:\DATA\"
    MyFile = Dir(Filepath)

    Set wsPaste = ActiveSheet
    With wsPaste
        lNextColumn = .Cells(3, .Columns.Count).End(xlToLeft).Column
    End With
    Do While Len(MyFile) > 0
        If MyFile = "zmaster.xlsm" Then
            Exit Sub
        End If

        Workbooks.Open (Filepath & MyFile)
        Range("B3:B603").Copy Destination:=wsPaste.Cells(3, lNextColumn)
        lNextColumn = lNextColumn + 1
        ActiveWorkbook.Close savechanges:=False
        MyFile = Dir
    Loop
End Sub

Answer:

I simplified your macro a little :

Sub LoopThroughDirectory()
Dim MyFile As String
Dim Filepath As String
Dim count as Integer
Filepath = "D:\DATA\"
MyFile = Dir(Filepath)
count = 3
Application.ScreenUpdating = False

While MyFile <> ""
    If MyFile = "zmaster.xlsm" Then Exit Sub
    Workbooks.Open (Filepath & MyFile)
    Workbooks(MyFile).sheets("Sheet1").Range("B3:B603").Copy thisworkbook.sheets("Sheet1").Cells(3, count)
    Workbooks(MyFile).Close
    count = count + 1
    MyFile = Dir
Loop

Application.ScreenUpdating = True
End Sub

Answer:

You need to recalculate the first free row before each paste, using this :

PasteRow = Ws.Range("A" & Ws.Rows.Count).End(xlUp).Row + 1

Give this a try :

Sub LoopThroughDirectory()
Dim MyFile As String
Dim Filepath As String
Dim Wb As Workbook, _
    Ws As Worksheet, _
    PasteRow As Long

Filepath = "D:\DATA\"
Set Ws = ActiveSheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False

MyFile = Dir(Filepath)
Do While Len(MyFile) > 0
    If MyFile = "zmaster.xlsm" Then
        Exit Sub
    End If

    PasteRow = Ws.Range("A" & Ws.Rows.Count).End(xlUp).Row + 1
    Set Wb = Workbooks.Open(Filepath & MyFile)
    Wb.Sheets(1).Range("B3:B603").Copy Destination:=Worksheets("Sheet1").Range("B" & PasteRow)
    Wb.Close

    MyFile = Dir
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub