Excel clear cells based on contents of a list in another sheet

Question

I have an excel Sheet1 of a thousand of rows and 20 columns from A1 to T1. Each cell in that range has some data in it, usually one or two words. In Sheet2, A1 column I have a list of data of 1000 values.

I am working on VBA script to find words from Sheet2 list in Sheet1 and clear the values of the cells of the found ones.

I now have a VBA script that works only on A1 column of Sheet1 and it deletes the rows only. Here's the script:

Sub DeleteEmails() 
Dim rList As Range 
Dim rCrit As Range 

With Worksheets("Sheet1") 
    .Range("A1").Insert shift:=xlDown: .Range("A1").Value = "Temp Header" 
    Set rList = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)) 
End With 
With Worksheets("Sheet2") 
    .Range("A1").Insert shift:=xlDown: .Range("A1").Value = "Temp Header" 
    Set rCrit = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)) 
End With 

rList.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False 
rList.Offset(1).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp 
Worksheets("Sheet1").ShowAllData 

rList(1).Delete shift:=xlUp: rCrit(1).Delete shift:=xlUp 

Set rList = Nothing: Set rCrit = Nothing 
End Sub 

Could anyone help me? I need the values cleared, not rows deleted, and this should work on all columns of Sheet1, not just A1.

Answer 1

Here is another method using an array by minimizing the traffic between sheet (iteration via range/cells) and code. This code doesn't use any clear contents. Simply take the whole range into an array, clean it up and input what you need :) with a click of a button.

• edited as per OP's request: adding comments and changing the code for his desired sheets.

Code:

Option Explicit

Sub matchAndClear()
    Dim ws As Worksheet
    Dim arrKeys As Variant, arrData As Variant
    Dim i As Integer, j As Integer, k As Integer

    '-- here we take keys column from Sheet 1 into a 1D array
    arrKeys = WorksheetFunction.Transpose(Sheets(1).Range("A2:A11").Value)
    '-- here we take to be cleaned-up-range from Sheet 2 into a 2D array
    arrData = WorksheetFunction.Transpose(Sheets(2).Range("C2:D6").Value)

    '-- here we iterate through each key in keys array searching it in 
    '-- to-be-cleaned-up array
    For i = LBound(arrKeys) To UBound(arrKeys)
        For j = LBound(arrData, 2) To UBound(arrData, 2)
                '-- when there's a match we clear up that element
                If UCase(Trim(arrData(1, j))) = UCase(Trim(arrKeys(i))) Then
                    arrData(1, j) = " "
                End If
                '-- when there's a match we clear up that element
                If UCase(Trim(arrData(2, j))) = UCase(Trim(arrKeys(i))) Then
                    arrData(2, j) = " "
                End If
        Next j
    Next i

    '-- replace old data with new data in the sheet 2 :)
    Sheets(2).Range("C2").Offset(0, 0).Resize(UBound(arrData, 2), _
    UBound(arrData)) = Application.Transpose(arrData)

End Sub

• Please not that you what you really need to set here are the ranges:

  1. Keys range
  2. To-Be-Cleaned up range

Output: (for displaying purpose I am using the same sheet, but you can change the sheet names as you desire.

Edit based on OP's request for running OP's file:

The reason that it didn't clean all your columns is that in the above sample is only cleaning two columns where as you have 16 columns. So you need to add another for loop to iterate through it. Not much performance down, but a little ;) Following is a screenshot after running your the sheet you sent. There is nothing to change except that.

Code:

'-- here we iterate through each key in keys array searching it in
    '-- to-be-cleaned-up array
    For i = LBound(arrKeys) To UBound(arrKeys)
        For j = LBound(arrData, 2) To UBound(arrData, 2)
            For k = LBound(arrData) To UBound(arrData)
                '-- when there's a match we clear up that element
                If UCase(Trim(arrData(k, j))) = UCase(Trim(arrKeys(i))) Then
                    arrData(k, j) = " "
                End If
            Next k
        Next j
    Next i

Answer 2

I don't have excel to hand right now so this may not be exactly 100% accurate on formulae name but I believe this line needs to change:

rList.Offset(1).SpecialCells(xlCellTypeVisible).Delete shift:=xlUp 

to

rList.Offset(1).ClearContents

once you've set rList to your desired selection. Delete is the reason you're deleting rows and not clearing them. (1) is the reason you were doing A1 only instead of entire range.

EDIT

The final code that I tested this with was (includes going over all columns now):

Option Explicit

Sub DeleteEmails()
    Dim rList As Range
    Dim rCrit As Range
    Dim rCells As Range
    Dim i As Integer

    With Worksheets("Sheet2")
        .Range("A1").Insert shift:=xlDown
        .Range("A1").Value = "Temp Header"
        Set rCrit = .Range("A1", .Cells(Rows.Count, 1).End(xlUp))
    End With

    Set rCells = Sheet1.Range("$A$1:$T$1")

    rCells.Insert shift:=xlDown

    Set rCells = rCells.Offset(-1)

    rCells.Value = "Temp Header"

    For i = 1 To rCells.Count
        Set rList = Sheet1.Range(rCells(1, i).address, Sheet1.Cells(Rows.Count, i).End(xlUp))

        If rList.Count > 1 Then  'if a column is empty as is in my test case, continue to next column
            rList.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=rCrit, Unique:=False
            rList.Offset(1).ClearContents
            Worksheets("Sheet1").ShowAllData
        End If
    Next i

    rCells.Delete shift:=xlUp
    rCrit(1).Delete shift:=xlUp

    Set rList = Nothing: Set rCrit = Nothing

End Sub

PS: may I request that you do not use ':' in vba. Its really hard to notice in vba's default IDE and took me a while to figure why things were happening but not making sense!