VBA Loop : Copy / Paste destination offsetting

Question

First of all thanks for your help. I need to copy / paste datas. The idea is the next : depending on the cells content from the sheet AAA I want to copy / paste the datas to the corresponding sheet (XXX if XXX or to ZZZ if ZZZ).My macro worked but the issue is that I have an offset bothering me. Imagine , the first lap will paste the data to XXX , but the second lap will copy to ZZZ , in this case I have an issue because it will copy paste to the 3rd cells (3,1) whereas the cell(2,1) is empty

Sub CopyPastingMyDate()
Dim i As Long
Dim lrow As Long
Dim lcol As Long
Dim RngOne As Range
Dim RngTwo As Range
Dim ws As Worksheet

Set ws = ThisWorkbook.Worksheets("AAA")
lrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
lcol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
Set RngOne = ws.Range(ws.Cells(lrow, 1), ws.Cells(1, lcol))

For i = 2 To lrow
    Set RngOne = ws.Range(ws.Cells(lrow, 1), ws.Cells(1, lcol))
    If ws.Cells(i, 1) = "XXX" Then
        Set RngTwo = ThisWorkbook.Worksheets("SheetXXX").Range(ThisWorkbook.Worksheets("SheetXXX").Cells(i, 1), ThisWorkbook.Worksheets("SheetXXX").Cells(i, lcol))
        RngOne.Copy
        RngTwo.PasteSpecial xlAll
    End If
    
    If ws.Cells(i, 1) = "ZZZ" Then
        Set RngTwo = ThisWorkbook.Worksheets("SheetZZZ").Range(ThisWorkbook.Worksheets("SheetZZZ").Cells(i, 1), ThisWorkbook.Worksheets("SheetZZZ").Cells(i, lcol))
        RngOne.Copy
        RngTwo.PasteSpecial xlAll
    End If
Next i

End Sub

How to fix it please ? I want to copy paste to from the first available cell. Thanks to all of you. JaNa

Tim Williams Tim Williams · Accepted Answer · 2021-02-15T19:01:28

Try this. I might be misunderstanding what you're copying though: I'm assuming each row needs to be copied to the correct sheet?

Sub CopyPastingMyDate()
    Dim i As Long
    Dim lrow As Long
    Dim lcol As Long
    Dim RngOne As Range
    Dim RngTwo As Range
    Dim ws As Worksheet, dest, wsDest As Worksheet
    
    Set ws = ThisWorkbook.Worksheets("AAA")
    lrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    lcol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    Set RngOne = ws.Range(ws.Cells(lrow, 1), ws.Cells(1, lcol))
    
    For i = 2 To lrow
        Select Case ws.Cells(i, 1).Value   'which destination sheet?
            Case "XXX": dest = "SheetXXX"
            Case "ZZZ": dest = "SheetZZZ"
            Case Else: dest = ""
        End Select
        
        If Len(dest) > 0 Then
            ws.Cells(i, 1).Resize(1, lcol).Copy 'copy the row
            Set wsDest = ThisWorkbook.Worksheets(dest)
            wsDest.Cells(wsDest.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlAll
        End If
    Next i

End Sub

VBA Loop : Copy / Paste destination offsetting

2 Answers