Copy paste using loop from multiple ranges to single row into another WB

Question

I am trying to copy data from multiple source files into a destination file. So a folder has all the source files I receive.

I now have to collate the data from the files received into a single workbook.

Source file Destination file/Collation file

I am trying to get some help in collating from each source file in the folder into the destination file.

Sub Transfer_data()
Dim wb As String
Dim i As Long
Dim j As Long
Dim lr As Long

    Application.ScreenUpdating = False
    
     i = 0
     j = 0
    
    wb = Dir(ThisWorkbook.Path & "\*")
    Do Until wb = ""
    
    If wb <> ThisWorkbook.Name Then
    
    Workbooks.Open ThisWorkbook.Path & "\" & wb
    
    With Workbooks(wb).Sheets("D. P & c data")
       
    
    For i = 21 To 26
    For j = 3 To 60 Step 10
   
    .Range(Cells(i, 3), Cells(i, 12)).Copy ThisWorkbook.Sheets("P and c data").Cells(Rows.Count, j).End(xlUp).Offset(1)
  
    
    Next j
    
    Next i
   
    
    End With
    
    Application.CutCopyMode = False
    Workbooks(wb).Close True
    
    End If
    wb = Dir
    Loop
    
    Application.ScreenUpdating = True
    MsgBox " Copy Complete"
    
End Sub

Answer 1

Copy Range by Row to Single Row

Option Explicit

' Copies values from a specified range (srcAddr)
' in a specified worksheet (srcID) in all workbooks ("*.xls*") in the folder
' of ThisWorkbook (ThisWorkbook excluded), to a specified worksheet (tgtID)
' in ThisWorkbook. The values of the range are copied into a single row
' starting from a specified column (tgtCol), each row of the range next
' to the previous.
Sub transferData()
    
    Const srcID As Variant = "D. P & c data" ' Name or Index e.g. "Sheet1" or 1
    Const srcAddr As String = "C21:L26"
    Const tgtID As Variant = "P and c data"  ' Name or Index e.g. "Sheet1" or 1
    Const tgtCol As Variant = 3              ' Number or String e.g. 1 or "A"
    Const Pattern As String = "*.xls*"
    
    Dim wbPath As String: wbPath = ThisWorkbook.Path & Application.PathSeparator
    Dim tgt As Worksheet: Set tgt = ThisWorkbook.Worksheets(tgtID)
    
    Application.ScreenUpdating = False
    
    Dim wb As Workbook, src As Worksheet, tgtCell As Range ' Objects
    Dim Source As Variant, Target As Variant               ' Arrays
    Dim i As Long, j As Long, l As Long, Count As Long     ' Counters (Longs)
    
    Dim wbname As String: wbname = Dir(wbPath & Pattern)
    Do Until wbname = ""
        If wbname <> ThisWorkbook.Name Then
            GoSub readSource
            GoSub writeSource
            GoSub writeTarget
        End If
WorksheetNotFound:
        wbname = Dir
    Loop
    
    Application.ScreenUpdating = True
    
    MsgBox "Copied data from " & Count & " workbook(s) containing " _
           & "a worksheet ID-ed with '" & srcID & "'.", _
           vbInformation, "Data Transfer"
  
Exit Sub

readSource:
    ' Write values from Source Range to Source Array.
    On Error Resume Next
    Set src = Workbooks.Open(wbPath & wbname).Worksheets(srcID)
    If Err.Number <> 0 Then GoTo closeSourceError
    On Error GoTo 0
    Source = src.Range(srcAddr).Value
    ' Uncomment the following line to write the names of the worksheets
    ' and the workbooks (that were read from) to the Immediate window (CTRL+G).
    Debug.Print src.Name, src.Parent.Name
    src.Parent.Close False ' Just reading, no need to save.
    Return
    
writeSource:
    ' Write values from Source Array to Target Array.
    ReDim Target(1 To 1, 1 To UBound(Source) * UBound(Source, 2))
    l = 0
    For i = 1 To UBound(Source)
        For j = 1 To UBound(Source, 2)
            l = l + 1
            Target(1, l) = Source(i, j)
        Next j
    Next i
    Return

writeTarget:
    ' Write values from Target Array to Target Range.
    Set tgtCell = tgt.Cells(tgt.Rows.Count, tgtCol).End(xlUp).Offset(1)
    tgtCell.Resize(, UBound(Target, 2)).Value = Target
    Count = Count + 1
    Return

closeSourceError:
    src.Parent.Close False ' Just reading, no need to save.
    On Error GoTo 0
    GoTo WorksheetNotFound
  
End Sub

Answer 2

I am unsure of what is going on in your code before and after the loop. I think the below loop is what you are looking for. Putting rows outside of columns is easier.

For i = 21 To 26
    For j = 3 To 13
        Dim lr As Long
            lr = ThisWorkbook.Sheets("P and c data").Range("C" & Rows.Count).End(xlUp).Row + 1
                Cells(i, j).Copy
                Sheets("P and c data").Cells(lr, 3).PasteSpecial

    Next j
Next i