Copying multiple columns from different workbooks to columns next to each other

Question

I am trying to pull data from a folder containing 300 Workbooks, named 001, 002 etc.
I want to copy data from column G of each file into a separate folder. Each file does not have the same amount if data in column G.

I have been able to copy the data across, but I can't get it to move past column B and instead writes over the previous column.

The output needed is:
data from column G workbook"001" pasted into "new sheet" column A
data from column G workbook"002" pasted into "new sheet" column B
and so on

Each file in the folder of 300 has one worksheet, each labelled: 001, 002, ..., 300

This is the code which results in two columns of data where one gets replaced by each new sheet.

Sub Copy()

Dim MyFile As String
Dim Filepath As String
Dim q As Long

Dim ThisCol As Integer
Dim ThisRow As Long
Dim CurS As Worksheet
Dim CurRg As Range
Dim InfCol As Integer

Set CurS = ActiveSheet
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
InfCol = 1

Filepath = "C:..."

MyFile = Dir(Filepath)

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

    Workbooks.Open (Filepath & MyFile)

    LastRow = Range("G1").CurrentRegion.Rows.Count

    Range("G1", Range("G" & LastRow)).Copy ThisWorkbook.Sheets("Sheet1").Range(CurS.Cells(ThisRow, ThisCol + 1), CurS.Cells(ThisRow, ThisCol + CurS.Cells(ThisRow, InfCol).Value))

    ActiveWorkbook.Save
    ActiveWorkbook.Close
    MyFile = Dir
Loop

End Sub

Answer 1

To properly copy in a new column each time, you need a variable that increments during each loop to offset by one each time. When you use ThisCol + 1 you're always getting the same value because ThisCol is not updated.

Something like this:

Sub Copy()

    Dim MyFile As String
    Dim Filepath As String
    Dim q As Long

    Dim ThisCol As Integer
    Dim ThisRow As Long
    Dim CurS As Worksheet
    Dim CurRg As Range
    Dim InfCol As Integer

    
    Set CurS = ActiveSheet
    ThisRow = ActiveCell.Row
    ThisCol = ActiveCell.Column
    InfCol = 1


    Filepath = ReplacewithyouFilePath

    MyFile = Dir(Filepath)

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

        'Let's keep a reference to the workbook
        Dim wb As Workbook
        Set wb = Workbooks.Open(Filepath & MyFile)
        
        'Let's keep a reference to the first sheet where the data is
        Dim ws As Worksheet
        Set ws = wb.Sheets(1)
        
        Dim LastRow As Long
        LastRow = ws.Range("G1").CurrentRegion.Rows.Count

        'We create a variable to increment at each column
        Dim Counter As Long
        
        'Let's make the copy operation using the Counter
        ws.Range("G1", ws.Range("G" & LastRow)).Copy CurS.Range(CurS.Cells(ThisRow, ThisCol + Counter), CurS.Cells(ThisRow + LastRow - 1, ThisCol + Counter))

        'We increment the counter for the next file
        Counter = Counter + 1

        'We use wb to make sure we are referring to the right workbook
        wb.Save
        wb.Close
        MyFile = Dir
        
        'We free the variables for good measure
        Set wb = Nothing
        Set ws = Nothing
    Loop


End Sub