CODEWITHSUNDEEP
vbaexcel
BennyC
BennyC

Reputation: 5

Copy row to next empty row of another sheet

I'm trying to copy rows into a new sheet based on several criteria.

I managed to write a macro that can find a row and copy it to a new sheet but unfortunately I'm overwriting the previous entries.

There are some Solutions to this on stackoverflow - I searched for things like "copy rows into a new sheet in empty row" etc. - but I just couldn't make them work by just copying some of the code in these answers (without a proper understanding of the code).

How do I copy the results to the next empty row in the new sheet?

Sub FilterAndCopy()

Dim lastRow As Long
Dim criterion As String
Dim team1 As String
Dim team2 As String
Dim team3 As String

criterion = "done"
team1 = "source"
team2 = "refine"
team3 = "supply"


Sheets("Sheet3").UsedRange.Offset(0).ClearContents

With Worksheets("Actions")
    .range("$A:$F").AutoFilter
    'filter for actions that are not "done"
    .range("$A:$F").AutoFilter field:=3, Criteria1:="<>" & criterion
    'filter for actions where "due date" is in the past
    .range("$A:$F").AutoFilter field:=6, Criteria1:="<" & CLng(Date)

    'FIRST TEAM
    .range("$A:$F").AutoFilter field:=4, Criteria1:="=" & team1
    'iff overdue actions exist, copy them into "Sheet3"
    lastRow = .range("A" & .rows.Count).End(xlUp).row
    If (lastRow > 1) Then
        .range("A1:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            Destination:=Sheets("Sheet3").range("A1")
    End If

    'SECOND TEAM
    .range("$A:$F").AutoFilter field:=4, Criteria1:="=" & team2
    'iff overdue items exist, copy them into "Sheet3"
    lastRow = .range("A" & .rows.Count).End(xlUp).row
    If (lastRow > 1) Then
        'find last row with content and copy relevant rows
        .range("A1:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            Destination:=Sheets("Sheet3").range("A1")
    End If

    'THIRD STREAM
    .range("$A:$F").AutoFilter field:=4, Criteria1:="=" & team3
    'iff overdue items exist, copy them into "Sheet3"
    lastRow = .range("A" & .rows.Count).End(xlUp).row
    If (lastRow > 1) Then
        'find last row with content and copy relevant rows
        .range("A1:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
            Destination:=Sheets("Sheet3").range("A1")
    End If

End With
End Sub

Upvotes: 0

Views: 979

Answers (1)

Hocus
Hocus

Reputation: 121

You simply need to use your LastRow Code again in the new sheet.

so try

If (lastRow > 1) Then
    LastRow2 = worksheets("Sheet3").range("A" & rows.count).end(xlup).row + 1
    'find last row with content and copy relevant rows
    .range("A1:A" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _
        Destination:=Sheets("Sheet3").range("A" & LastRow2)
End If

This finds the last used row of your sheet 3 and will paste it below it.

Hope this helps.

Upvotes: 2

Related Questions