Copy range not pasting in the right row

user_16633745 0
Viewed 57

I am trying to create a code where i loop through three types of worksheets and copy rows of data in a dynamic range in those sheets and paste it in the mastersheet. Part of the data i'm copying needs to be pasted to column D of my master worksheet in a running list (i.e., data should not overwrite each other and should create a list in column D). The other part of the data in a copied row will not be in column D in the master worksheet but need to be in the same row as the data in column D. i need column C data to be in the same row as each other even if they're in different columns

I've been able to do it for two of my type of worksheets(let's call them a and b), but not my third one (worksheet c). The issue is that for worksheets a and b is that the data in worksheet a match the columns i am pasting them to in the mastersheet. For worksheet c, that is not the case, so part of my data is being pasted in a row different from the rest of the worksheet c data. Finding the dynamic range to be pasted over was slightly harder for worksheet c as well. I knew the column and the last row constraint, but not the starting row, which you'll see in the code

Please help!!

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
range copy-paste vba excel
1 Answers

I think this is pretty close to what you want:

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
user_4788840
Related