CODEWITHSUNDEEP
vbaexcel
Asia
Asia

Reputation: 41

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

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

Upvotes: 4

Views: 2713

Answers (3)

mauek unak
mauek unak

Reputation: 772

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

Upvotes: 1

Rory
Rory

Reputation: 34045

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

Upvotes: 1

R3uK
R3uK

Reputation: 14537

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

Upvotes: 1

Related Questions