复制范围未粘贴在右行

Question

我正在尝试创建一个代码，在其中循环三种类型的工作表，并在这些工作表的动态范围内复制数据行并将其粘贴到母版表中。我正在复制的部分数据需要粘贴到运行列表中我的主工作表的 D 列（即，数据不应相互覆盖，并且应在 D 列中创建一个列表）。复制行中的另一部分数据将不在主工作表的 D 列中，但需要与 D 列中的数据位于同一行。

我已经能够为我的两种类型的工作表（我们称之为 a 和 b）做到这一点，但不是我的第三个（工作表 c）。问题在于，对于工作表 a 和 b，工作表 a 中的数据与我将它们粘贴到主表中的列相匹配。对于工作表 c，情况并非如此，因此我的部分数据被粘贴在与工作表 c 数据的其余部分不同的行中。对于工作表 c，找到要粘贴的动态范围也稍微困难一些。我知道列和最后一行约束，但不知道起始行，您将在代码中看到

请帮忙！！

Dim ws As Worksheet
Dim targetws As Worksheet
Dim LastRow As Long
Dim openitemstartrow As Variant

LastRow = Cells(Rows.Count, "D").End(xlUp).Row
Set targetws = Sheets("targetwsname")

For Each ws In ActiveWorkbook.Worksheets
'this is the copy paste command for worksheet a
 If ws.Name Like "*" & "WorksheetA" & "*" Then
    ws.Range("C4:G" & ws.Range("D" & Rows.Count).End(xlUp).Row).Copy 
    Destination:=targetws.Range("D" & Rows.Count).End(xlUp).Offset(1)
        Else
 'this is the copy paste command for worksheet b
           If ws.Name Like "*" & "WorksheetB" & "*" Then
                ws.Range("C4:I" & ws.Range("D" & Rows.Count).End(xlUp).Row).Copy 
                Destination:=targetws.Range("D" & Rows.Count).End(xlUp).Offset(1)
            End If

   'this is the code for worksheet c
           If ws.Name Like "*" & "WorksheetC" & "*" Then
            'to find the starting row number for the range i want to copy and paste
              openitemstartrow = Application.Match("Open Items:", ws.Range("C:C"), 0)
                 'cell c4 indicates whether this is anything to copy paste from worksheet c
                 If Not IsEmpty(ws.Cells(4, "C")) Then
              'have to copy and paste range as values in my masterworksheet to ignore formulas
                  ws.Range("C" & openitemstartrow + 1, ws.Range("C" & openitemstartrow + 10).End(xlUp)).Copy
                  ws.Range("C" & openitemstartrow + 1, ws.Range("C" & openitemstartrow + 10).End(xlUp)).PasteSpecial Paste:=xlPasteValues
                

       'this is the part of code i am struggling with. the range from column C of the worksheet c pastes correctly but i need the range from columns K and L of the worksheet c to paste to the same row as my column C data.
                  ws.Range("C" & openitemstartrow + 1, ws.Range("C" & openitemstartrow + 10).End(xlUp)).Copy
                  targetws.Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
                  ws.Range("E" & openitemstartrow + 1, ws.Range("F" & openitemstartrow + 10).End(xlUp)).Copy
                  targetws.Range("K" & Rows.Count, "L" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
                   End If
               End If
       
       End If

'End If

 Next ws

 End Sub

Answer 1

我认为这非常接近您想要的：

Sub Tester()
    Dim ws As Worksheet
    Dim targetws As Worksheet
    Dim LastRow As Long, targetRow As Long, rngCopy As Range
    Dim openitemstartrow As Variant
    
    LastRow = Cells(Rows.Count, "D").End(xlUp).Row
    
    Set targetws = Sheets("targetwsname")
    targetRow = targetws.Cells(Rows.Count, "D").End(xlUp).Row + 1 'first paste row
    
    For Each ws In ActiveWorkbook.Worksheets
        
        Set rngCopy = Nothing 'reset
        
        If ws.Name Like "*WorksheetA*" Then
            Set rngCopy = ws.Range("C4:G" & ws.Range("D" & Rows.Count).End(xlUp).Row)
            rngCopy.Copy targetws.Cells(targetRow, "D")
        End If
            
        If ws.Name Like "*WorksheetB*" Then
             Set rngCopy = ws.Range("C4:I" & ws.Range("D" & Rows.Count).End(xlUp).Row)
             rngCopy.Copy targetws.Cells(targetRow, "D")
        End If
    
        If ws.Name Like "*WorksheetC*" Then
            If Not IsEmpty(ws.Cells(4, "C")) Then 'anything to copy?
                openitemstartrow = Application.Match("Open Items:", ws.Range("C:C"), 0)
                If Not IsError(openitemstartrow) Then 'got a match?
                    Set rngCopy = ws.Range("C" & openitemstartrow + 1, ws.Range("C" & openitemstartrow + 10).End(xlUp))
                    CopyValues rngCopy, targetws.Cells(targetRow, "D")
                     
                    Set rngCopy = rngCopy.EntireRow.Columns("K:L") 'same rows but K:L
                    CopyValues rngCopy, targetws.Cells(targetRow, "K")
                End If 'got match
            End If 'something to copy
        End If 'C sheet
        
        'need to increment target row?
        If Not rngCopy Is Nothing Then targetRow = targetRow + rngCopy.Rows.Count
    
    Next ws

End Sub

'utility sub: copy values from `rngFrom` to `rngTo`
Sub CopyValues(rngFrom As Range, rngTo As Range)
    rngTo.Resize(rngFrom.Rows.Count, rngFrom.Columns.Count).Value = rngFrom.Value
End Sub