VBA ClearContents from range of cells in a row if Value in Column A can't be found in Column A of another sheet

[EC1728]

Hello everyone,

I am hoping someone can help me find a solution that works faster than the current one I am using.

I have 2 sheets "LOF Summary" and "Car List - Assign."
Sheet 1 contains data in columns A to M.
Sheet 2 contains data only in column A.

I want a code that will check the data found in column A (range A4:A28) of Sheets("Car List - Assign.") with those in Column A (Range A7:A1000) of Sheets("LOF Summary").

If an exact match is NOT found in Column A of Sheets("LOF Summary"), Excel will only clear the contents of the row from Column A to Column H.

Here is the code I am using which does work but it takes around 30 or more seconds for it to process. I am hoping to find a faster or more efficient code.

Sub test()

Dim LR As Long, i As Long
Application.ScreenUpdating = False
With Sheets("LOF Summary")
    LR = .Range("A" & Rows.Count).End(xlUp).Row
    For i = LR To 6 Step -1
        If IsError(Application.Match(.Range("A" & i).Value, Sheets("Car List - Assign.").Columns("A"), 0)) Then .Range("A" & i & ":H" & i).ClearContents
    Next i
End With
Range("A7:H" & LR).Sort Key1:=Range("A7:H" & LR), Order1:=xlAscending, Header:=xlNo
Application.ScreenUpdating = True

End Sub

 

[kevin9999]

It's always difficult without seeing a copy of your actual data - you could use the XL2BB Tool to help us to help you.

I timed the following code on 10K rows of data on the LOF Summary sheet at <0.25 seconds. Please try it on a copy of your data. I've given an option depending on how you want to sort the sheet after processing.

Option Explicit
Sub EC1728_Cars()
    Dim t As Single: t = Timer
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("LOF Summary")
    Set ws2 = Worksheets("Car List - Assign")
    
    Dim lc As Long, lr As Long, i As Long
    lc = ws1.Cells.Find("*", , xlFormulas, , 2, 2).Column + 1
    lr = ws1.Cells(Rows.Count, 1).End(3).Row

    With Application
        .Calculation = xlManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Dim a, b, c, temp As String
    a = ws1.Range("A7:A" & lr).Value    '<< this is the full range on the LOF Summary sheet
    b = ws2.Range("A4:A28").Value       '<< this is a fixed range on the Car List sheet - you may want to adjust
    ReDim c(1 To UBound(a), 1 To 1)

    For i = LBound(a, 1) To UBound(a, 1)
        temp = a(i, 1)
        If IsNumeric(Application.Match(temp, b, 0)) Then c(i, 1) = 1
    Next i

    ws1.Cells(7, lc).Resize(UBound(c)).Value = c
    i = WorksheetFunction.Sum(ws1.Columns(lc))
    ws1.Range(Cells(7, 1), Cells(lr, lc)).Sort Key1:=Cells(7, lc), order1:=1, Header:=2
    If i > 0 Then ws1.Cells(7, 1).Resize(i, 8).ClearContents
    ws1.Columns(lc).ClearContents
    
    '*** IF you want the newly cleared rows A-H at the bottom of the range...
    '*** ...then uncomment the next 2 lines
    'lr = ws1.Cells(Rows.Count, 9).End(3).Row
    'ws1.Range(Cells(7, 1), Cells(lr, lc - 1)).Sort Key1:=Cells(7, 1), order1:=1, Header:=2
    
    With Application
        .Calculation = xlAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
    MsgBox Timer - t
End Sub

 

[Peter_SSs]

@kevin9999
Based on the OP's original code (that worked as required),
- the newly cleared rows are at the bottom so you would have those extra lines uncommented.
- your code does not do the same thing as the OP's (even after the uncommenting). Your code sorts the whole range whereas it is only column A:H that are sorted in the original code.

@EC1728
This is my version. Like yours, it only sorts A:H. It is also at least twice as fast as @kevin9999's though I doubt you would notice the difference as they are both quite fast. My sample data also 10,000 rows at 0.05 secs)

If you have large data and lots of formulas then you may not get anything like the speed of our tests but should be a considerable improvement on 30 seconds.

Test with a copy of your data.

Sub Clear_Values()
  Dim d As Object
  Dim a As Variant
  Dim i As Long, k As Long
  
  With Application
    .Calculation = xlManual
    .EnableEvents = False
    .ScreenUpdating = False
  End With
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Car List - Assign.")
    a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    d(a(i, 1)) = 1
  Next i
  With Sheets("LOF Summary")
    With .Range("A7:H" & .Range("A" & Rows.Count).End(xlUp).Row)
      a = .Columns(1).Value
      For i = 1 To UBound(a)
        If Not d.exists(a(i, 1)) Then
          a(i, 1) = vbNullString
          k = k + 1
        End If
      Next i
      If k > 0 Then
        .Columns(1).Value = a
        .Sort Key1:=.Columns(1), order1:=xlAscending, Header:=xlNo
        .Rows(UBound(a) - k + 1).Resize(k).ClearContents
      End If
    End With
  End With
  With Application
    .Calculation = xlAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
  End With
End Sub

 

[kevin9999]

@kevin9999
Based on the OP's original code (that worked as required),
- the newly cleared rows are at the bottom so you would have those extra lines uncommented.
- your code does not do the same thing as the OP's (even after the uncommenting). Your code sorts the whole range whereas it is only column A:H that are sorted in the original code.

@EC1728
This is my version. Like yours, it only sorts A:H. It is also at least twice as fast as @kevin9999's though I doubt you would notice the difference as they are both quite fast. My sample data also 10,000 rows at 0.05 secs)

If you have large data and lots of formulas then you may not get anything like the speed of our tests but should be a considerable improvement on 30 seconds.

Test with a copy of your data.

Sub Clear_Values()
  Dim d As Object
  Dim a As Variant
  Dim i As Long, k As Long
 
  With Application
    .Calculation = xlManual
    .EnableEvents = False
    .ScreenUpdating = False
  End With
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Car List - Assign.")
    a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    d(a(i, 1)) = 1
  Next i
  With Sheets("LOF Summary")
    With .Range("A7:H" & .Range("A" & Rows.Count).End(xlUp).Row)
      a = .Columns(1).Value
      For i = 1 To UBound(a)
        If Not d.exists(a(i, 1)) Then
          a(i, 1) = vbNullString
          k = k + 1
        End If
      Next i
      If k > 0 Then
        .Columns(1).Value = a
        .Sort Key1:=.Columns(1), order1:=xlAscending, Header:=xlNo
        .Rows(UBound(a) - k + 1).Resize(k).ClearContents
      End If
    End With
  End With
  With Application
    .Calculation = xlAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
  End With
End Sub

Nice code @Peter_SSs It was also kind of you not to point out that I had the logic back to front - I was zapping the rows that did match the second sheet instead of keeping them. As a matter personal pride, I've reposted my code below for my own personal reference (even though yours is definitely faster).
Cheers

Sub EC1728_Cars()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("LOF Summary")
    Set ws2 = Worksheets("Car List - Assign")
    
    Dim lc As Long, lr As Long, i As Long
    lc = ws1.Cells.Find("*", , xlFormulas, , 2, 2).Column + 1
    lr = ws1.Cells(Rows.Count, 1).End(3).Row

    With Application
        .Calculation = xlManual
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Dim a, b, c, temp As String
    a = ws1.Range("A7:A" & lr).Value    '<< this is the full range on the LOF Summary sheet
    b = ws2.Range("A4:A28").Value       '<< this is a fixed range on the Car List sheet - you may want to adjust
    ReDim c(1 To UBound(a), 1 To 1)

    For i = LBound(a, 1) To UBound(a, 1)
        temp = a(i, 1)
        If Not IsNumeric(Application.Match(temp, b, 0)) Then c(i, 1) = 1
    Next i

    ws1.Cells(7, lc).Resize(UBound(c)).Value = c
    i = WorksheetFunction.Sum(ws1.Columns(lc))
    ws1.Range(Cells(7, 1), Cells(lr, lc)).Sort Key1:=Cells(7, lc), order1:=1, Header:=2
    If i > 0 Then ws1.Cells(7, 1).Resize(i, 8).ClearContents
    ws1.Columns(lc).ClearContents
    
    lr = ws1.Cells(Rows.Count, 9).End(3).Row
    ws1.Range(Cells(7, 1), Cells(lr, 9)).Sort Key1:=Cells(7, 1), order1:=1, Header:=2
    
    With Application
        .Calculation = xlAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
End Sub

 

[Peter_SSs]

It was also kind of you not to point out that I had the logic back to front

Haha, I should claim that I was being nice - but actually I hadn't even noticed that. ?

 

[EC1728]

@kevin9999
Based on the OP's original code (that worked as required),
- the newly cleared rows are at the bottom so you would have those extra lines uncommented.
- your code does not do the same thing as the OP's (even after the uncommenting). Your code sorts the whole range whereas it is only column A:H that are sorted in the original code.

@EC1728
This is my version. Like yours, it only sorts A:H. It is also at least twice as fast as @kevin9999's though I doubt you would notice the difference as they are both quite fast. My sample data also 10,000 rows at 0.05 secs)

If you have large data and lots of formulas then you may not get anything like the speed of our tests but should be a considerable improvement on 30 seconds.

Test with a copy of your data.

Sub Clear_Values()
  Dim d As Object
  Dim a As Variant
  Dim i As Long, k As Long
 
  With Application
    .Calculation = xlManual
    .EnableEvents = False
    .ScreenUpdating = False
  End With
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Car List - Assign.")
    a = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Value
  End With
  For i = 1 To UBound(a)
    d(a(i, 1)) = 1
  Next i
  With Sheets("LOF Summary")
    With .Range("A7:H" & .Range("A" & Rows.Count).End(xlUp).Row)
      a = .Columns(1).Value
      For i = 1 To UBound(a)
        If Not d.exists(a(i, 1)) Then
          a(i, 1) = vbNullString
          k = k + 1
        End If
      Next i
      If k > 0 Then
        .Columns(1).Value = a
        .Sort Key1:=.Columns(1), order1:=xlAscending, Header:=xlNo
        .Rows(UBound(a) - k + 1).Resize(k).ClearContents
      End If
    End With
  End With
  With Application
    .Calculation = xlAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
  End With
End Sub

@Peter_SSs This is perfect! Works flawlessly and very fast. I really appreciate the help.

 

[Peter_SSs]

You're welcome. Thanks for the follow-up.