macro to cut & paste rows to another sheet (with multiple criteria) - vba

[Alice88]

I'm looking for some help on (hopefully) a fairly simple vba code.

I have a long list (600+) with only 2 columns: Flowers in A, quantity in B
Here's an excerpt of Sheet1:

Rose 15
Lilac 8
Geranium 5
Tulip 20
Syringa 4
Daffodil 15

I need to move the rows with "Lilac" to Sheet2. It should be a cut and move, so the entire Lilac row will disappear from Sheet1.

Here's my problems:
1) "Lilac" is often labelled as "Syringa" (it's scientific name). So I need the vba code to identify both criteria.
2) When moving to Sheet2, it should be pasted from Row 10 down. The space above I want to reserve for some graphics and logos.

I know I can filter, cut and paste, but I'm seeing this as a great learning opportunity.
Thanks in advance!!

 

[mohadin]

Hi
Try

Sub test()
    Dim rng As Range
    Dim trng As Range
    With Sheets("Sheet1")
        For i = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
            If .Cells(i, 1) = "Lilac" Or .Cells(i, 1) = "Syringa" Then
                If rng Is Nothing Then
                    Set rng = .Range(.Cells(i, 1), .Cells(i, 2))
                   Set trng = rng
                Else
                    Set trng = Union(trng, .Range(.Cells(i, 1), .Cells(i, 2)))
                End If
            End If
        Next
        trng.Copy Sheets("sheet2").Cells(10, 1)
        trng.EntireRow.Delete
    End With
End Sub

 

[kevin9999]

I'm seeing this as a great learning opportunity.

That being the case, please see the code below. There's often more than one way to do things with VBA.

Option Explicit '<< Always use this - forces declaration of variables & prevents lots of problems

Sub Alice88()

'   Declare variables
    Dim WsSrc As Worksheet, WsDest As Worksheet
    Dim LRow As Long

'   Set the variables
    Set WsSrc = Worksheets("Sheet1")    '<< give variables intuitive names e.g. WsSrc = Source worksheet
    Set WsDest = Worksheets("Sheet2")   '<< you may need to change these to your actual sheet names
    
    LRow = WsDest.Cells(Rows.Count, "A").End(xlUp).Row + 1  '<< finds the last empty row in column A in the destination sheet
'   The Lrow (=Last row) is where you'll be copying the data to on the destination sheet

'   Set an Autofilter on the source sheet for Lilac and Syringa
'   Note the uuse of the asterisk wildcard - * - in case there are accidental spaces at the start or end of the names
    With WsSrc.Range("A1").CurrentRegion  '<< A With block needs and End With statement at the end
        .AutoFilter Field:=1, Criteria1:="*Lilac*", Operator:=xlOr, Criteria2:="*Syringa*"
'   Check to make sure there are actually some records selected - if not, stop code execution
        If WorksheetFunction.CountA(.Columns("A")) = 1 Then '<< test if only the header row is showing
            MsgBox "No records selected"                    '<< if so, tell the user
            .AutoFilter                                     '<< turn the autofilter off
            Exit Sub                                        '<< Exit the sub
        End If
'   Offset by 1 row to exclude the headers from the copy
        .Offset(1).Copy WsDest.Range("A" & LRow)    '<< copy the filtered value to the destintion sheet
        .Offset(1).EntireRow.Delete                 '<< then delete those rows on the source sheet
        .AutoFilter                                 '<< turn the autofilter off
    End With

End Sub

 

[kevin9999]

Version2 (test for records showing was incorrect)

Option Explicit '<< Always use this - forces declaration of variables & prevents lots of problems

Sub Alice88_V2()

'   Declare variables
    Dim WsSrc As Worksheet, WsDest As Worksheet
    Dim LRow As Long

'   Set the variables
    Set WsSrc = Worksheets("Sheet1")    '<< give variables intuitive names e.g. WsSrc = Source worksheet
    Set WsDest = Worksheets("Sheet2")   '<< you may need to change these to your actual sheet names
    
    LRow = WsDest.Cells(Rows.Count, "A").End(xlUp).Row + 1  '<< finds the last empty row in column A in the destination sheet
'   The Lrow (=Last row) is where you'll be copying the data to on the destination sheet

'   Set an Autofilter on the source sheet for Lilac and Syringa
'   Note the uuse of the asterisk wildcard - * - in case there are accidental spaces at the start or end of the names
    With WsSrc.Range("A1").CurrentRegion  '<< A With block needs and End With statement at the end
        .AutoFilter Field:=1, Criteria1:="*Lilac*", Operator:=xlOr, Criteria2:="*Syringa*"
'   Check to make sure there are actually some records selected - if not, stop code execution
        If Range("A:A").SpecialCells(xlCellTypeVisible).Rows.Count = 1 Then '<< test if only the header row is showing
            MsgBox "No records selected"                    '<< if so, tell the user
            .AutoFilter                                     '<< turn the autofilter off
            Exit Sub                                        '<< Exit the sub
        End If
'   Offset by 1 row to exclude the headers from the copy
        .Offset(1).Copy WsDest.Range("A" & LRow)    '<< copy the filtered value to the destintion sheet
        .Offset(1).EntireRow.Delete                 '<< then delete those rows on the source sheet
        .AutoFilter                                 '<< turn the autofilter off
    End With

End Sub

 

[kevin9999]

Hi Alice, I just noticed that you wanted the rows pasted on row 10 on sheet2 - not on the first blank row. Please se the amended code below.

Option Explicit '<< Always use this - forces declaration of variables & prevents lots of problems

Sub Alice88_V3()

'   Declare variables
    Dim WsSrc As Worksheet, WsDest As Worksheet
    Dim LRow As Long

'   Set the variables
    Set WsSrc = Worksheets("Sheet1")    '<< give variables intuitive names e.g. WsSrc = Source worksheet
    Set WsDest = Worksheets("Sheet2")   '<< you may need to change these to your actual sheet names
    
    LRow = WsDest.Cells(Rows.Count, "A").End(xlUp).Row + 1  '<< finds the last empty row in column A in the destination sheet
'   The Lrow (=Last row) is where you'll be copying the data to on the destination sheet
'   IF you wanted it pasted to the first available blank row - you'll pick row 10 instead

'   Set an Autofilter on the source sheet for Lilac and Syringa
'   Note the uuse of the asterisk wildcard - * - in case there are accidental spaces at the start or end of the names
    With WsSrc.Range("A1").CurrentRegion  '<< A With block needs and End With statement at the end
        .AutoFilter Field:=1, Criteria1:="*Lilac*", Operator:=xlOr, Criteria2:="*Syringa*"
'   Check to make sure there are actually some records selected - if not, stop code execution
        If Range("A:A").SpecialCells(xlCellTypeVisible).Rows.Count = 1 Then '<< test if only the header row is showing
            MsgBox "No records selected"                    '<< if so, tell the user
            .AutoFilter                                     '<< turn the autofilter off
            Exit Sub                                        '<< Exit the sub
        End If
'   Offset by 1 row to exclude the headers from the copy
        .Offset(1).Copy WsDest.Range("A10")         '<< copy the filtered value to the destination sheet - row 10
        .Offset(1).EntireRow.Delete                 '<< then delete those rows on the source sheet
        .AutoFilter                                 '<< turn the autofilter off
    End With

End Sub

 

[Alice88]

Thank you both!!
I like the first code for its simplicity - tested and it works great!
I haven't tested yours yet Kevin as I am working through the notes. Really appreciate you providing those. I'm a total beginner so it helps tons.

 

[kevin9999]

Thank you both!!
I like the first code for its simplicity - tested and it works great!
I haven't tested yours yet Kevin as I am working through the notes. Really appreciate you providing those. I'm a total beginner so it helps tons.

Glad we could help, and thanks for the feedback
Please note my correction in post #5

 

[Alice88]

Glad we could help, and thanks for the feedback
Please note my correction in post #5

Wonderful! - I didn't even catch that. I'll use it as the solution Thanks!!