My goal is to automatically copy a range of columns (A:C) from 40 Excel Sheet into one Sheet located in the same workbook.

The structure of all sheets is identical. Columns consist of numeric values. I want the columns to be added to the right at each iteration (so the target sheet will be enriched horizontally with the data)

My attempt (see the code below) is not automated as if I have to specify Sheet Names and Target Cell where it is possible to copy the columns

Sub macro()
    Sheets("Top").Select
    Columns("A:C").Select
    Selection.Copy
    Sheets("Low").Select
    Range("D1").Select
    ActiveSheet.Paste
End Sub

Any help is appreciated! Thank you

CodePudding user response：

Please, try the next code. It will iterate between all existing sheets and copy all rows of columns "D:K" from all sheets in one named "Destination" (starting from "A1"). If you need it to start from "D1" it would be easy to adapt the code:

Sub copyAllSheetsInOne()
   Dim ws As Worksheet, sh As Worksheet, lastRow As Long, lastEmptyCol As Long, i As Long
   
   Set sh = Worksheets("Destination") 'a sheet named "Destination" must exist in the workbook to be processed
   sh.cells.ClearContents             'clear its content (for cases when code run before)

   'some optimization to make the code faster:
   Application.DisplayAlerts = False: Application.EnableEvents = False
   Application.Calculation = xlCalculationManual
   'iterate between all existing sheets:
   For Each ws In ActiveWorkbook.Worksheets
        If ws.name <> "Destination" Then
            lastEmptyCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column   1
            lastRow = ws.Range("D" & ws.rows.count).End(xlUp).row
            If lastEmptyCol = 2 Then lastEmptyCol = 1 'for the first sheet
        
            ws.Range("D1", ws.Range("K" & lastRow)).Copy sh.cells(1, lastEmptyCol)
        End If
   Next ws
   Application.DisplayAlerts = True: Application.EnableEvents = True
   Application.Calculation = xlCalculationAutomatic
End Sub