基於另一個表中的列表內容的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中很難注意到，並花了我一些時間來弄清楚爲什麼發生了事情，但沒有意義！