CODEWITHSUNDEEP
vbaexcel
Wolf
Wolf

Reputation: 125

Deleting rows based on criteria

I have a little code so I can move specific rows to a specific sheet which is structured as follows:

So basically the code looks for a keyword on a specific column, and copies all rows that meet that criteria on the specified column from sheet 1 to sheet 2, it does that like a charm. The problem I have is because of data organization, I need to delete the rows once they have been copied, I tried using the .cut target instead of .copy target, and it works too, but it takes extremely long (about 1+ min), and it looks like that whole time is frozen as it doesn't let you select anything.

Any suggestions to accomplish this more efficiently? I am learning VBA, so please bear with me.

Sub Copydatatoothersheet()
    Dim c As Range
    Dim j As Integer
    Dim Source As Worksheet
    Dim Target As Worksheet

    ' Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Sheet1")
    Set Target = ActiveWorkbook.Worksheets("Sheet2")

    j = 3     ' Start copying to row 3 in target sheet
    Application.ScreenUpdating = False
    For Each c In Source.Range("BB:BB")
        If c = "UNPAID" Then
        'THIS IS THE LINE WHERE I REPLACE COPY WITH CUT
           Source.Rows(c.Row).Copy Target.Rows(j)
           j = j + 1
        End If
    Next c
    Application.ScreenUpdating = True
End Sub

Upvotes: 1

Views: 396

Answers (2)

YasserKhalil
YasserKhalil

Reputation: 9538

Try store the desired ranges in a variable then delete the entire rows of that stored range

Sub Copydatatoothersheet()
Dim c As Range
Dim j As Integer
Dim source As Worksheet
Dim target As Worksheet
Dim oRange As Range

' Change worksheet designations as needed
Set source = ActiveWorkbook.Worksheets("Sheet1")
Set target = ActiveWorkbook.Worksheets("Sheet2")

j = 3     ' Start copying to row 3 in target sheet
Application.ScreenUpdating = False
For Each c In source.Range("BB:BB")
    If c = "UNPAID" Then
    'THIS IS THE LINE WHERE I REPLACE COPY WITH CUT
       source.Rows(c.Row).Copy target.Rows(j)
       If oRange Is Nothing Then Set oRange = c Else Set oRange = 
Union(oRange, c)
       j = j + 1
    End If
Next c
If Not oRange Is Nothing Then oRange.EntireRow.Delete
Application.ScreenUpdating = True
End Sub

Upvotes: 3

DisplayName
DisplayName

Reputation: 13386

Use AutoFilter

Sub foo()
    Dim Source As Worksheet
    Dim Target As Worksheet

    ' Change worksheet designations as needed
    Set Source = ActiveWorkbook.Worksheets("Sheet1")
    Set Target = ActiveWorkbook.Worksheets("Sheet2")

    With Source
        With .Range("BB:BB" & .Cells(.Rows.Count, "BB").End(xlUp).Row) 'reference its column BB cells from row 1 (header) down to last not empty one
            .AutoFilter field:=1, Criteria1:= "UNPAID"' filter referenced cells on 1st column with "UNPAID" content
            If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then
                With .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                    Intersect(.EntireRow, .Parent.UsedRange), .Parent.UsedRange).Copy Destination:=Target.Range("A1") ' if any filtered cell other than the header then copy their entire rows and paste to 'Target' sheet starting from its cell A1
                    .EntireRow.Delete ‘finally, delete these rows
                End With
            End If
        End With
        .AutoFilterMode = False
    End With
End Sub

You may also add the ScreenUpdating toggling

Upvotes: 1

Related Questions