Excel根据另一个工作表中列表的内容清除单元格

Question

我有一个excel Sheet1，包括从A1到T1的一千行和20列。该范围内的每个单元格都包含一些数据，通常是一个或两个单词。 在Sheet2中，A1列我有一个1000个值的数据列表。

我正在使用VBA脚本从Sheet1中的Sheet2列表中查找单词，并清除找到的单元格的值。

我现在有一个仅适用于Sheet1的A1列的VBA脚本，它只删除行。这是脚本：

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 

有人能帮帮我吗？我需要清除值，而不是删除行，这应该适用于Sheet1的所有列，而不仅仅是A1。

Answer 1

我现在没有优势，所以这可能不是公式名称的100％准确，但我相信这条线需要改变：

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

到

rList.Offset(1).ClearContents

一旦将rList设置为所需的选择。 Delete是您删除行而不清除行的原因。 (1)是你A1而不是整个范围的原因。

修改

我测试的最终代码是（包括现在遍历所有列）：

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：我可以要求你不要在vba中使用'：'。在vba的默认IDE中真的很难注意到，并花了一些时间来弄清楚为什么事情正在发生但没有意义！

Answer 2

这是通过最小化工作表（通过范围/单元格迭代）和代码之间的流量来使用数组的另一种方法。此代码不使用任何clear contents。只需点击一个按钮，只需将整个范围放入一个阵列，清理并输入您需要的内容。

• 按照OP的要求编辑：添加评论并更改所需图纸的代码。

代码：

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

• 请注意，您真正需要设置的范围是：

  1. 按键范围
  2. 待清洁范围

输出:(出于显示目的，我使用相同的工作表，但您可以根据需要更改工作表名称。

根据OP运行OP文件的请求进行编辑：

它没有清除所有列的原因是上面的示例中只清理了两列，其中有16列。所以你需要添加另一个for循环来迭代它。性能下降不多，但有点;）以下是运行您发送的工作表后的屏幕截图。除此之外没有任何改变。

代码：

'-- 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