使用循环从多个范围复制粘贴到单行到另一个 WB

Question

我正在尝试将数据从多个源文件复制到目标文件中。 所以一个文件夹包含了我收到的所有源文件。

我现在必须将收到的文件中的数据整理到一个工作簿中。

Source file Destination file/Collation file

我正在尝试从文件夹中的每个源文件整理到目标文件中获得一些帮助。

子 Transfer_data() 将 wb 变暗为字符串 暗淡我只要 暗淡 j 只要 暗淡无光

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"

结束子

Answer 1

我不确定您的代码在循环之前和之后发生了什么。我认为下面的循环是你正在寻找的。将行放在列之外更容易。

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

Answer 2

按行复制范围到单行

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