Macro to clear content from cells based on content in another sheet

[Slimat]

Hi Guys

I think I am making this too complicated - but and struggling to find an answer.

I have two sheets -

sheet1 has two columns with text in both.

On sheet2 I have several columns which "may" contain an exact match to the contents of the cells in either column from sheet1. I need a way to clear the contents from any cells on sheet2 that exactly match the contents from the cells on sheet1.

It must be an "exact" lookup as there are cells in sheet2 which contain the contents in sheet1 but with extra information too.

Can anyone help? Thanks in advance

 

[Slimat]

Please check the working sample file below with the same code.
Sheet1 has 3 columns. The code considers only columns A and B.
In Sheet2, there are values from Sheet1 columns A, B (yellow) and C (orange).
The code deletes the only yellow values in Sheet2 and shifts the cells left.

This is the best I can do. I don't know why you are having trouble. You may have to modify the code according to your needs.

WeTransfer | Send Large Files Fast - Up To 2GB Free

The simple, quick and secure way to send your files around the world without an account. Share your files, photos, and videos today for free.

we.tl

Yes, yours seems to work perfectly... here you can see two variations on the same file... the first is without shifting the empty cells left - so you can see the results but theyre spread over 25 (ish) columns. Then there is another file with the left shifting included and you can see the data presented is incorrect I am sure its something wrong at my end... but just cant work out whats wrong

Course calculator (with shifting left).xlsm

Both files are in this link

 

[Legacy 143009]

Ok, I've found the problem. That's my fault, sorry.. Because we are deleting, we have to start from reverse. Here, find the working code for you:

Sub test()
  Dim sheet2Range As Range, sheet1Array As Variant
  Dim sheet1Dictionary As Object, i As Long, j As Long
  Set sheet1Dictionary = CreateObject("Scripting.Dictionary")
 
  With Worksheets("Sheet1")
  sheet1Array = Intersect(.UsedRange, .Range("A:B"))
  End With

  For Each elemnt In sheet1Array
    If Not sheet1Dictionary.Exists(elemnt) And Trim(element) <> "" Then
      sheet1Dictionary.Add elemnt, 1
    End If
  Next
 
  With Worksheets("Sheet2")
  Set sheet2Range = .Range("$C$2:" & Split(.UsedRange.Address, ":")(1))
  Application.ScreenUpdating = False
  For j = sheet2Range.Columns.Count To 1 Step -1
    For i = 1 To sheet2Range.Rows.Count
      If sheet1Dictionary.Exists(sheet2Range.Cells(i, j).Value) Then
        sheet2Range.Cells(i, j).Delete Shift:=xlShiftToLeft
      End If
    Next
  Next
  Application.ScreenUpdating = True
  End With
End Sub

 

[Slimat]

Ok, I've found the problem. That's my fault, sorry.. Because we are deleting, we have to start from reverse. Here, find the working code for you:

Sub test()
  Dim sheet2Range As Range, sheet1Array As Variant
  Dim sheet1Dictionary As Object, i As Long, j As Long
  Set sheet1Dictionary = CreateObject("Scripting.Dictionary")
 
  With Worksheets("Sheet1")
  sheet1Array = Intersect(.UsedRange, .Range("A:B"))
  End With

  For Each elemnt In sheet1Array
    If Not sheet1Dictionary.Exists(elemnt) And Trim(element) <> "" Then
      sheet1Dictionary.Add elemnt, 1
    End If
  Next
 
  With Worksheets("Sheet2")
  Set sheet2Range = .Range("$C$2:" & Split(.UsedRange.Address, ":")(1))
  Application.ScreenUpdating = False
  For j = sheet2Range.Columns.Count To 1 Step -1
    For i = 1 To sheet2Range.Rows.Count
      If sheet1Dictionary.Exists(sheet2Range.Cells(i, j).Value) Then
        sheet2Range.Cells(i, j).Delete Shift:=xlShiftToLeft
      End If
    Next
  Next
  Application.ScreenUpdating = True
  End With
End Sub

Hi @Flashbond, I tried this one in the sheet I sent called "Course calculator (without shifting left).xlsm - I renamed the sheets - sheet1 & sheet2 - however when I copied your script in to it, it made no visible effect when I ran it

I am very happy with the earlier script and my add-on which deleted/shifted all the cells with "xxx" in them as this does exactly what I needed and I don't want you to waste time on this... but I am very happy to keep trying your scripts. I am very grateful for all the help you have given

 

[Legacy 143009]

Just change this one letter and it will work. I promise

And Trim(element) <> "" Then to
And Trim(elemnt) <> "" Then

 

[Slimat]

Just change this one letter and it will work. I promise

And Trim(element) <> "" Then to
And Trim(elemnt) <> "" Then

Boom - worked perfectly

Do you want to post the whole corrected script so I can mark as solution? Saves someone reading the whole thread

Many thanks for all the work - much slicker than my method... so much quicker.

Thanks

 

[Legacy 143009]

Finally Very thoughtful idea indeed. Thanks for your patience an follow up Here is the full working code:

Sub test()
  Dim sheet2Range As Range, sheet1Array As Variant
  Dim sheet1Dictionary As Object, i As Long, j As Long
  Set sheet1Dictionary = CreateObject("Scripting.Dictionary")
 
  With Worksheets("Sheet1")
  sheet1Array = Intersect(.UsedRange, .Range("A:B"))
  End With

  For Each elemnt In sheet1Array
    If Not sheet1Dictionary.Exists(elemnt) And Trim(elemnt) <> "" Then
      sheet1Dictionary.Add elemnt, 1
    End If
  Next
 
  With Worksheets("Sheet2")
  Set sheet2Range = .Range("$C$2:" & Split(.UsedRange.Address, ":")(1))
  Application.ScreenUpdating = False
  For j = sheet2Range.Columns.Count To 1 Step -1
    For i = 1 To sheet2Range.Rows.Count
      If sheet1Dictionary.Exists(sheet2Range.Cells(i, j).Value) Then
        sheet2Range.Cells(i, j).Delete Shift:=xlShiftToLeft
      End If
    Next
  Next
  Application.ScreenUpdating = True
  End With
End Sub

 

[Slimat]

Finally Very thoughtful idea indeed. Thanks for your patience an follow up Here is the full working code:

Sub test()
  Dim sheet2Range As Range, sheet1Array As Variant
  Dim sheet1Dictionary As Object, i As Long, j As Long
  Set sheet1Dictionary = CreateObject("Scripting.Dictionary")
 
  With Worksheets("Sheet1")
  sheet1Array = Intersect(.UsedRange, .Range("A:B"))
  End With

  For Each elemnt In sheet1Array
    If Not sheet1Dictionary.Exists(elemnt) And Trim(elemnt) <> "" Then
      sheet1Dictionary.Add elemnt, 1
    End If
  Next
 
  With Worksheets("Sheet2")
  Set sheet2Range = .Range("$C$2:" & Split(.UsedRange.Address, ":")(1))
  Application.ScreenUpdating = False
  For j = sheet2Range.Columns.Count To 1 Step -1
    For i = 1 To sheet2Range.Rows.Count
      If sheet1Dictionary.Exists(sheet2Range.Cells(i, j).Value) Then
        sheet2Range.Cells(i, j).Delete Shift:=xlShiftToLeft
      End If
    Next
  Next
  Application.ScreenUpdating = True
  End With
End Sub

Tested again and works perfectly... thanks for the hard work