VBA Function help - Delete entire Row as per Criteria

[Mallesh23]

Hi Team,

I want to delete entire Row if a cell contain Single value, or it contain multiple values in a Column.
for that I have created Function , it work for Single Criteria. which is Very fast.

1) how to make it further dynamic for multiple Criteria.
2) if My Actual StartRow of data starts from Row 4, how to make it dynamic. Thanks for your help in advance.

Below is my attempted code, works for Single Criteria

Option Explicit

Sub DeleteRow_asper_Criteria()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Dim a As Variant
    Dim MultipleCriteria As Variant
       
     a = Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
    
    '======Delete Single Criteria Row====
    DeleteRow ws, a, "Chris Gayle"  'Delete Single Criteria
    
    '----------Delete Multiple Criteria--------------
    MultipleCriteria = Array("MS Dhoni", "Ricky Ponting", "Brendon McCullum")
   
    
   '1)How to make  code dynamic for multiple Criteria
  ' 2) If Data startRow is 4 Row , how to make this also dynamic.
    
    
  MsgBox "Macro Successful"


End Sub


Function DeleteRow(ByVal ws As Worksheet, ByVal a As Variant, Criteria1 As String, Optional MultipleCriteria As String)
 ' Dim a As Variant, b As Variant
  Dim nc As Long, i As Long, k As Long
  Dim b As Variant
    
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    If a(i, 1) = Criteria1 Then    'How to make this line dynamic for multiple Criteria
      b(i, 1) = 1
      k = k + 1
    End If
  Next i
  If k > 0 Then
    Application.ScreenUpdating = False
    With Range("A2").Resize(UBound(a), nc)  'How to make this line dynamic if startRow changes.
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
  
End Function

Book2
	A	B	C
1	Big Hitters	SIXES	Fours
2	Ricky Ponting	403	2553
3	Sourav Ganguly	359	1240
4	MS Dhoni	409	2034
5	Adam Gilchrist	363	3597
6	Sachin Tendulkar	372	3984
7	Ricky Ponting	435	1258
8	Chris Gayle	394	2206
9	Virender Sehwag	398	1729
10	Chris Gayle	482	3498
11	Ricky Ponting	392	3960
12	Sourav Ganguly	443	2829
13	MS Dhoni	499	1688
14	Adam Gilchrist	475	1888
15	Sachin Tendulkar	431	2813
16	Brendon McCullum	407	1193
17	Chris Gayle	234	1473
18	Virender Sehwag	421	3646
19	Shane Watson	465	2526
20	Ricky Ponting	435	3852
21	Chris Gayle	363	1554
22	MS Dhoni	253	3717
23	Adam Gilchrist	458	3677
24	Sachin Tendulkar	382	3754
25	Brendon McCullum	424	1056
26	Chris Gayle	317	1032
27	Virender Sehwag	212	1106
28	Ricky Ponting	217	1362
29	Sourav Ganguly	456	1484
30	MS Dhoni	225	2178
31	Adam Gilchrist	240	2340
32	Sachin Tendulkar	466	2480
33	Brendon McCullum	481	3921
34	Chris Gayle	397	1201
35	Virender Sehwag	417	1079
36	Shane Watson	280	3595
Sheet1

 

[jasonb75]

Isn't this just a new variation of the same question that you asked here?

VBA Help - .SpecialCells(xlConstants, xlLogical).EntireRow.Delete

Hi Team, I want to delete all rows where cells value "Keep" and "#N/A" 20000 rows want to delete. I used autofilter, loop, it worked, Trying to learn new and multiple ways .... Below code I got from this forum. its very fast How to fit my requirement into below logic and delete entire...

www.mrexcel.com

 

[Mallesh23]

Hi Jason,

Yes its similar to that, I was searching which method is faster for deleting rows.
I found this solution on this forum given by peter_Sss, its superb speed. It deleted 1000000 rows within 3 seconds.

this method is faster than loop, autofilter, replace approach, Therefore I want to use this method by Converting into function.




Thanks
mg

 

[Mallesh23]

Hi Team,

Below code is working Perfectly. for deleting multiple rows with multiple Criteria and as per table.
however is there we can shorten the code further. Thanks

[CODE=vba]Option Explicit
Sub DeleteRow_asper_Criteria()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Dim a As Variant
    Dim str As String
    Dim ary() As String
       
    a = ws.Range("A2", Range("A" & Rows.Count).End(xlUp)).Value
   '  a = ws.Range("d5", Range("D" & Rows.Count).End(xlUp)).Value
    
    
    str = "Virender Sehwag"
    ary = Split(str, ",")
    
    'Call Function
    DeleteRow ws, a, ary, 1 'Delete Single Criteria
      
  
  MsgBox "Macro Successful"

End Sub


Function DeleteRow(ByVal ws As Worksheet, ByVal a As Variant, ByVal ary As Variant, Optional ByVal HeaderRow As Long = 1)
  Dim nc As Long, i As Long, k As Long
  Dim b As Variant, j As Long
  Dim DataRow As Long
  DataRow = HeaderRow + 1
      
  nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
  ReDim b(1 To UBound(a), 1 To 1)
  For i = 1 To UBound(a)
    For j = 0 To UBound(ary)
    If a(i, 1) = ary(j) Then
      b(i, 1) = 1
      k = k + 1
    End If
    Next j
  Next i

  If k > 0 Then
    Application.ScreenUpdating = False
    
    With ws.Range("A" & DataRow).Resize(UBound(a), nc) 'How to make this line dynamic if startRow changes.
      .Columns(nc).Value = b
      .Sort Key1:=.Columns(nc), Order1:=xlAscending, Header:=xlNo
      .Resize(k).EntireRow.Delete
    End With
    Application.ScreenUpdating = True
  End If
  
End Function

[/CODE]

Thanks
mg