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

 

[Legacy 143009]

Thanks for the followup You are welcome

 

[Legacy 143009]

To grant some referances:

Sub test()
  Dim sheet2Array As Variant, 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")) 'Any two adjacent columns in Sheet1
  End With

  For Each elemnt In sheet1Array
    If Not sheet1Dictionary.Exists(elemnt) Then
      sheet1Dictionary.Add elemnt, 1
    End If
  Next
 
  With Worksheets("Sheet2")
  sheet2Array = .Range("$C$1:" & Split(.UsedRange.Address, ":")(1))
  For i = 1 To UBound(sheet2Array, 1)
    For j = 1 To UBound(sheet2Array, 2)
      If sheet1Dictionary.Exists(sheet2Array(i, j)) Then
        sheet2Array(i, j) = ""
      End If
    Next
  Next
  .Range("C1").Resize(UBound(sheet2Array, 1), UBound(sheet2Array, 2)).Value = sheet2Array
  End With
End Sub

 

[Slimat]

To grant some referances:

Sub test()
  Dim sheet2Array As Variant, 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")) 'Any two adjacent columns in Sheet1
  End With

  For Each elemnt In sheet1Array
    If Not sheet1Dictionary.Exists(elemnt) Then
      sheet1Dictionary.Add elemnt, 1
    End If
  Next
 
  With Worksheets("Sheet2")
  sheet2Array = .Range("$C$1:" & Split(.UsedRange.Address, ":")(1))
  For i = 1 To UBound(sheet2Array, 1)
    For j = 1 To UBound(sheet2Array, 2)
      If sheet1Dictionary.Exists(sheet2Array(i, j)) Then
        sheet2Array(i, j) = ""
      End If
    Next
  Next
  .Range("C1").Resize(UBound(sheet2Array, 1), UBound(sheet2Array, 2)).Value = sheet2Array
  End With
End Sub

This works really well @Flashbond , thanks - I am now wondering if there is a way to edit this line;

sheet2Array(i, j) = ""

so that instead of creating an empty cell, it could be deleted entirely and everything shifted left - that way the final data sheet wont have lots of empty cells and data spread across several columns? I did substitute with;

sheet2Array(i, j).Delete Shift:=xlShiftToLeft

but this didn't just get rid of the empty cells, as I expected, it corrupted the results

Is there a simple amendment to do this?

Thanks

 

[Legacy 143009]

It is possible but will be much slower:

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")) 'Any two adjacent columns in Sheet1
  End With

  For Each elemnt In sheet1Array
    If Not sheet1Dictionary.Exists(elemnt) Then
      sheet1Dictionary.Add elemnt, 1
    End If
  Next
 
  With Worksheets("Sheet2")
  Set sheet2Range = .Range("$C$1:" & Split(.UsedRange.Address, ":")(1))
  For i = 1 To sheet2Range.Rows
    For j = 1 To sheet2Range.Columns
      If sheet1Dictionary.Exists(sheet2Range.Cells(i, j).Value) Then
        sheet2Range.Cells(i, j).Delete Shift:=xlShiftToLeft
      End If
    Next
  Next
  End With
End Sub

 

[Slimat]

It is possible but will be much slower:

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")) 'Any two adjacent columns in Sheet1
  End With

  For Each elemnt In sheet1Array
    If Not sheet1Dictionary.Exists(elemnt) Then
      sheet1Dictionary.Add elemnt, 1
    End If
  Next
 
  With Worksheets("Sheet2")
  Set sheet2Range = .Range("$C$1:" & Split(.UsedRange.Address, ":")(1))
  For i = 1 To sheet2Range.Rows
    For j = 1 To sheet2Range.Columns
      If sheet1Dictionary.Exists(sheet2Range.Cells(i, j).Value) Then
        sheet2Range.Cells(i, j).Delete Shift:=xlShiftToLeft
      End If
    Next
  Next
  End With
End Sub

This doesnt work for me... I think its because some of the data in the cells on the live sheet has the colon symbol ) in them, this may be causing a problem as I noticed some of the data after the : in the results gets removed after running the above script. I also get an error;

The line this refers to is;

For i = 1 To sheet2Range.Rows

I am wondering whether the content of the cells may be causing the issue. So I may try replacing the empty cells with something unique (e.g. "xxx") and then write a script to remove any cells containing "xxx" and shift left

 

[Legacy 143009]

I am not in front of the cımputer. Could you please try Rows.Count and Columns.Count?

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")) 'Any two adjacent columns in Sheet1
  End With

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

If you still have problems Incan help you tomorrow.

 

[Slimat]

Thanks - I have only just seen your reply, so haven't tried it yet. In case anyone else is looking for something similar I edited your script to insert "xxx" in the matched cells instead of emptying them. Then compiled a script to search for "xxx" in any cells and delete/shift left.

This now does exactly what I needed - even if its a messy way of doing it. The script I added to search and remove/shift left is;

Dim c As Range, FoundCells As Range
Dim firstaddress As String

Application.ScreenUpdating = False
With Sheets("sheet2")
    'find first cell that contains "xxx"
    Set c = .Cells.Find(What:="xxx", After:=.Cells(Rows.Count, 1), LookIn:=xlValues, LookAt:= _
    xlPart, MatchCase:=False)
   
    'if the search returns a cell
    If Not c Is Nothing Then
        'note the address of first cell found
        firstaddress = c.Address
        Do
            'FoundCells is the variable that will refer to all of the
            'cells that are returned in the search
            If FoundCells Is Nothing Then
                Set FoundCells = c
            Else
                Set FoundCells = Union(c, FoundCells)
            End If
            'find the next instance of "xxx"
            Set c = .Cells.FindNext(c)
        Loop While Not c Is Nothing And firstaddress <> c.Address
               
        'after entire sheet searched, select all found cells
        FoundCells.Select
    Else
        'if no cells were found in search, display msg
        MsgBox "No cells found."
    End If
End With
Application.ScreenUpdating = True
Selection.Delete Shift:=xlToLeft

I will try your Rows.Count and Columns.Count suggestion tomorrow and report back. Many thanks again.

 

[Legacy 143009]

I am not in front of the cımputer. Could you please try Rows.Count and Columns.Count?

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")) 'Any two adjacent columns in Sheet1
  End With

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

If you still have problems Incan help you tomorrow.

I've tested it. I just works flawlessly. I am perfect

 

[Slimat]

Hi @Flashbond

I have tested the last script and the Rows.Count and Columns.Count has fixed the "Run Time Error 13" problem... but as far as I can tell when I test it, it doesn't seem to be removing the data found in sheet1 - so I end up with all the data exactly as it was at the start... I am struggling to see exactly what it is doing - is it possible to upload my xlsm sheet (with identifiable data removed) so you can see my actual layout?

 

[Legacy 143009]

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 & Share Photos Online - Up to 2GB Free

WeTransfer is the simplest way to send your files around the world

we.tl