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

Posted 2023-02-21

【中文标题】Excel 根据另一张工作表中列表的内容清除单元格

【英文标题】：Excel clear cells based on contents of a list in another sheet

【发布时间】：2012-12-27 11:52:32

【问题描述】：

我有一个从 A1 到 T1 的一千行和 20 列的 Excel Sheet1。该范围内的每个单元格中都有一些数据，通常是一两个单词。 在 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。

【问题讨论】：

使用.Find查看此链接siddharthrout.com/2011/07/14/find-and-findnext-in-excel-vba

@CamSpy 基于该值，您是要清除该单元格还是删除整行还是只删除该单元格？

@bonCodigo 我想清除单元格，以保留其他列/行的顺序

@SiddharthRout 与他所做的一样，AdvancedFilter 正是适合这项工作的工具。当 find 甚至不是这里的问题时，我不明白人们如何投票。

@Maverik：不是循环每一列，而是循环 Sheet2 中列中的单元格，并使用 .Find 查找 Sheet1 中的值，然后使用 .ClearContents 如果找到该单词，所以我不知道你不明白哪一部分:)

【参考方案1】：

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

根据 OP 的要求进行了编辑：添加 cmets 并更改所需工作表的代码。

代码：

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

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

键范围 待清理范围

输出：（出于显示目的，我使用的是同一张工作表，但您可以根据需要更改工作表名称。

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

【讨论】：

@Camspy 如果你有兴趣，你也可以试试这个 :) PS：我意识到我在给你评论后忘记发布 hte 代码 ;)

您的代码是否匹配整个单元格内容？我已经在对 Maverick 回答的最新评论中解释了这一点

@CamSpy 如果您愿意，您也可以在工作表中定义整个单元格。 （顺便说一句，如果您要通过单元格遍历整个工作表，那么这是一个巨大的性能下降......所以您最好进行这样的迭代）。这不会有您指出的任何匹配问题。精确的搜索关键字匹配;)

+1 这确实是一个非常好的解决方案，我很高兴你能得到这个被接受的答案。唯一的问题：它太技术性了！所以希望你能坚持下去，直到这完全符合 OP 的需求，因为 OP 可能无法轻松地遵循逻辑。

@bonCodigo 我们都在这里学习和分享我们的知识。我很高兴我学到了不同的方法。我从没想过使用 Transpose 使数组超出范围。这很巧妙 :) 仅此一点，我很乐意让你把答案归功于（无论如何你的答案是优秀的，最好的答案应该被标记出来）

【参考方案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 中很难注意到它，我花了一段时间才弄清楚为什么事情会发生但没有意义！

【讨论】：

我在尝试执行按照您编写的方式编辑的脚本时收到编译错误语法错误消息。

猜猜我得拿 excel 来模拟你的工作表 :) 给我半个小时

@CamSpy 现在应该已修复。我认为是 ClearContents 末尾的 () 让 vba 被淘汰了。

我之前弄错了行，因为你使用了难以捉摸的 ':'（我认为它是命名参数的一部分并忽略了第二行）

谢谢，这似乎适用于 Sheet1 的 A 列。您现在能告诉我如何更改代码以使其适用于所有 A-T 列吗？