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

2 回答

• 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
  

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

  • 键范围

  • 待清理范围

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

  

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

  回复于 2024-04-30T22:13:59+08:00
• 2

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

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

  至

  rList.Offset(1).ClearContents
  

  一旦你将rList设置为你想要的选择 . Delete 是您删除行而不清除行的原因 . (1) 是你只做 A1 而不是整个范围的原因 .

  EDIT

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

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

  回复于 2024-04-30T22:13:59+08:00