Help with VBA Code - Delete Rows based on Criteria

[Wigman86]

Hello Everyone

I have the below code where I am copying rows from the data tab that contain Day1 or Day2 or Day3 in column 9 and pasting these rows into the "Data2" tab. I then want to delete all the rows I have pasted to the new tab from the original data tab but am not sure how to do so. Some help would be greatly appreicated : ). Thanks.




Private Sub CommandButton1_Click()


a = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row


For i = 11 To a


If (Worksheets("Data").Cells(i, 9).Value = "Day 1" Or Worksheets("Data").Cells(i, 9).Value = "Day 2" Or Worksheets("Data").Cells(i, 9).Value = "Day 3" Then


Worksheets("Data").Rows(i).Copy
Worksheets("Data2").Activate


b = Worksheets("Data2").Cells(Rows.Count, 1).End(xlUp).Row


Worksheets("Data2").Cells(b + 1, 1).Select


ActiveSheet.Paste


Worksheets("Data").Activate




End If


Next


End Sub

 

[dmt32]

Hi,
try this

Sub CommandButton1_Click()
    Dim c As Range, CopyRange As Range, DataRange As Range
    Dim DestRange As Range
    Dim Lr As Long
    Dim m As Variant


    With ThisWorkbook
'source sheet
        With .Sheets("Data")
            Lr = .Cells(.Rows.Count, 9).End(xlUp).Row
            Set DataRange = .Range(.Cells(1, 9), .Cells(Lr, 9))
        End With
        
'destination sheet
        With .Sheets("Data2")
            Lr = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            Set DestRange = .Cells(Lr, 1)
        End With
    End With
    
    DataRange.EntireRow.Hidden = False
    


    For Each c In DataRange.Cells
        m = Application.Match(c.Value, Array("Day 1", "Day 2", "Day 3"), False)
        If Not IsError(m) Then
            If CopyRange Is Nothing Then
                Set CopyRange = c
            Else
                Set CopyRange = Union(CopyRange, c)
            End If
        End If
    Next c
    
    If Not CopyRange Is Nothing Then
    
    With CopyRange.EntireRow
'copy records to Data2 sheet
        .Copy DestRange
'delete records from Data sheet
        .Delete shift:=xlShiftUp
    End With
    
    End If

Set CopyRange = Nothing
End Sub

Always make backup when testing new code

Hope Helpful

Dave

 

[Fluff]

How about

Private Sub CommandButton1_Click()
   Dim Ary As Variant
   
   Ary = Array("Day 1", "Day 2", "Day 3")

   With Worksheets("Data")
      If .AutoFilterMode Then .AutoFilterMode = False
      Intersect(.UsedRange, .Rows(10)).AutoFilter 9, Ary, xlFilterValues
      .AutoFilter.Range.Offset(1).SpecialCells(xlVisible).Copy Worksheets("Data2").Range("A" & Rows.Count).End(xlUp).Offset(1)
      .AutoFilter.Range.Offset(1).SpecialCells(xlVisible).EntireRow.Delete
      .AutoFilterMode = False
   End With
End Sub