optimize this code??

[pakilprogramador]

please help me,, how to optimize this code to work with millions of data ???

Sub deleterowssearching_sheet2()
Dim H1, H2, x1, x2
Set H1 = Sheets("Hoja1")
Set H2 = Sheets("Hoja2")
For x1 = H1.Range("C" & Rows.Count).End(xlUp).Row To 1 Step -1
  For x2 = 1 To H2.Range("C" & Rows.Count).End(xlUp).Row
      If UCase(H1.Range("C" & x1)) Like "*" & UCase(H2.Range("C" & x2)) & "*" Then
        H1.Rows(x1).Delete
        Exit For
      End If
  Next
Next
End Sub

 

[Hui]

How many rows and columns does your data contain?

The columns shouldnt affect it any way as the code only looks at Column C and deletes the entire row anyway

How long does it take to run now?

 

[Hui]

Can you please let me know how this code goes

Option Explicit

Sub deleterowssearching_sheet3()

Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet
Dim lngLastR As Long, lngCnt As Long
Dim var1 As Variant, var2 As Variant, x
Dim rng1 As Range, rng2 As Range
Dim nr As Integer, i As Integer

Set Sh1 = Sheets("Hoja1")
Set Sh2 = Sheets("Hoja2")
Set Sh3 = Sheets("Hoja3")

Application.ScreenUpdating = False

'sheet1 range and fill array
With Sh1
  lngLastR = .Range("A" & .Rows.Count).End(xlUp).Row
  Set rng1 = .Range("A1:E" & lngLastR) 'Adjust to suit Columns
  var1 = rng1
End With
Sh1.Cells.ClearContents

'sheet2 range and fill array
With Sh2
  lngLastR = .Range("A" & .Rows.Count).End(xlUp).Row
  Set rng2 = .Range("C1:C" & lngLastR)
  var2 = rng2
End With

'first check sheet1 against sheet2
On Error GoTo NoMatch1
For lngCnt = 1 To UBound(var1)
  x = Application.WorksheetFunction.Match(var1(lngCnt, 3), rng2, False) 'Adjust 3 as lookup Column
Next

On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub

NoMatch1:
  'Transfer unique row to Sh1
  nr = Sh1.Range("A" & Sh3.Rows.Count).End(xlUp).Offset(1).Row
  For i = 1 To UBound(var1, 2)
  Sh1.Cells(nr, i) = var1(lngCnt, i)
  Next
   
  Resume Next

End Sub

see attached example

 

[Smallman]

@Pakipropamador

Your code will take a long time to run because of all of the loops you are asking Excel to perform. As your data only deals in Col C I would recommend you don't use VBA at all to solve this one. Put a formula in Col D of Sheet1 (Hoja1) that looks like this:

=COUNTIF(Hoja2!C:C,"*"&C2)

Drag it to the bottom of your range. Now put an autofilter on and filter by 1. Then delete the rows. Should take you about 10 seconds.

Or if you are wedded to VB here is the VBA equivalent.

Sub Goski()
    Range("C2", Range("C" & Rows.Count).End(xlUp)).Offset(, 1)  _
    = "=COUNTIF(Hoja2!C:C,""*""&C2)"
    Range("D1", Range("D" & Rows.Count).End(xlUp)).AutoFilter 1, ">" & 0
    Range("D2", Range("D" & Rows.Count).End(xlUp)).EntireRow.Delete
    [D1].AutoFilter
End Sub

It assumes you have a heading in C1.

File attached to prove workings.

Take care

Smallman

 

[pakilprogramador]

very very well, thank you very much @Hui , @Smallman .

other way:

Sub pakilprogramador()
On Error Resume Next
Dim H1, H2, x1 As Long, Rango As Range
Dim Total As Long, Celda As Range, Hora
Set H1 = Sheets("Hoja1")
Set H2 = Sheets("Hoja2")
Hora = Time
H2.Select: H2.Range("C2").Select
Application.ScreenUpdating = 0

For x1 = 1 To H1.Range("C" & Rows.Count).End(xlUp).Row
  Total = Total + 1
  If Total Mod 10000 = 0 Then
      Application.StatusBar = Hora & " Processing row " & _
                Total & " of  " & _
                H1.Range("C" & Rows.Count).End(xlUp).Row & " "
  End If
 
  Set Celda = H2.Range("C2:C" & H2.Range("C" & Rows.Count).End(xlUp).Row).Find _
      (What:=H1.Range("C" & x1).Value, LookIn:=xlValues)
  If Not Celda Is Nothing Then
      If Rango Is Nothing Then
        Set Rango = H1.Rows(x1)
      Else
        Set Rango = Application.Union(Rango, H1.Rows(x1))
      End If
  End If
 
Next

H1.Select
Application.StatusBar = "Eliminating ....."
If Not Rango Is Nothing Then Rango.Delete
Application.StatusBar = Hora & " Ready ... " & Time
Application.StatusBar = ""
Application.ScreenUpdating = 1
End Sub

thank's all.