基于另一个表中的列表内容的Excel清除单元格

Question

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

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

我现在有一个VBA脚本，它只对Sheet1的A1列起作用，它只删除行。这里的脚本：

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

这是另一种方法，通过最小化工作表（通过范围/单元格迭代）和代码之间的流量来使用数组。此代码不使用任何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 

Answer 2

我没有Excel现在出手所以这可能不会对公式名称完全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中很难注意到，并花了我一些时间来弄清楚为什么发生了事情，但没有意义！