VBA for copying multiple columns from different workbooks to be in columns next to each other-CodePudding

I am trying to pull data from a folder containing 300 Workbooks, each named 001, 002 etc. I am only interested in pulling the data from column G of each file and copying it into a separate folder (each file does not have the same amount if data in row G)

I have been able to copy the data across, but I can't seem to get it to move past column 2 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 only has 1 worksheet each, each labelled: 001,002,...,300

This is the code I already had which results in 2 columns of data where 1 gets replaced by each new sheet instead.

Any help to solve this issue would be greatly appreciated.

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

CodePudding user response：

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

CodePudding user response：

Import Columns

Sub ImportColumns()

    Const FOLDER_PATH As String = "C:\Test"
    Const FILE_EXTENSION_PATTERN As String = "*.xls*"
    Const SOURCE_WORKSHEET_ID As Variant = 1
    Const SOURCE_COLUMN As String = "G"
    Const SOURCE_FIRST_ROW As Long = 1
    Const DESTINATION_WORKSHEET_NAME As String = "Sheet1"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
    Const DESTINATION_COLUMN_OFFSET As Long = 1
    
    Dim pSep As String: pSep = Application.PathSeparator
    
    Dim FolderPath As String: FolderPath = FOLDER_PATH
    If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
    Dim DirPattern As String: DirPattern = FolderPath & FILE_EXTENSION_PATTERN
    
    Dim SourceFileName As String: SourceFileName = Dir(DirPattern)
    If Len(SourceFileName) = 0 Then
        MsgBox "No files found.", vbExclamation
        Exit Sub
    End If
    
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    Dim dws As Worksheet: Set dws = dwb.Worksheets(DESTINATION_WORKSHEET_NAME)
    Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    
    Application.ScreenUpdating = False
    
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim srg As Range
    Dim sfCell As Range
    Dim slCell As Range
    
    Do While Len(SourceFileName) > 0
        If StrComp(SourceFileName, "Text to column.xlsm", vbTextCompare) _
                <> 0 Then ' Why 'Exit Sub'? Is this the destination file?
            Set swb = Workbooks.Open(FolderPath & SourceFileName, True, True)
            Set sws = swb.Worksheets(SOURCE_WORKSHEET_ID)
            Set sfCell = sws.Cells(SOURCE_FIRST_ROW, SOURCE_COLUMN)
            Set slCell = sws.Cells(sws.Rows.Count, SOURCE_COLUMN).End(xlUp)
            Set srg = sws.Range(sfCell, slCell)
            srg.Copy dfCell
            ' Or, if you only need values without formulas and formats,
            ' instead, use the more efficient:
            'dfCell.Resize(srg.Rows.Count).Value = srg.Value
            Set dfCell = dfCell.Offset(, DESTINATION_COLUMN_OFFSET) ' next col.
            swb.Close SaveChanges:=False ' we are just reading, no need to save!
        'Else ' it's "Text to column.xlsm"; do nothing
        End If
        SourceFileName = Dir
    Loop

    Application.ScreenUpdating = True
    
    MsgBox "Columns imported.", vbInformation

End Sub