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

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

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

我现在有一个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

这里是另一种使用数组的方法，通过最小化工作表（通过范围/单元格迭代）和代码之间的stream量。 此代码不使用任何clear contents 。 简单地把整个范围放入一个数组中，清理并input你需要的东西:)点击一个button。

• 根据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

我现在没有办法，所以这可能不完全准确的公式名称，但我相信这条线需要改变：

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

至

 rList.Offset(1).ClearContents 

一旦你设置rList到你想要的select。 Delete是您删除行并不清除它们的原因。 (1)是你只做A1而不是整个范围的原因。

编辑

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

 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中很难注意到，并花了我一些时间来弄清为什么事情正在发生，但没有意义！