excel - Excel VBA - 如果区域中的单元格具有相同的值，则删除整行

Question

附上详细说明工作表布局的屏幕截图：

问题：如果“场景”列或 K 列中的所有值与“ID”列或 A 列中的同一 ID 的值相同，如何删除整行？

例如，ID 为“1”的行将被删除，因为“场景”列下的行值相同。但是 ID 为“2”的行将被保留，因为“场景”列下的行值不同。

对于每个 ID，ID 行数保持固定为 16。这意味着 ID 1 将占用 16 行，ID 2 也将占用 16 行，依此类推。

标签： excelvba

Answer 1

如果您将其放入 Worksheet 私有模块中，则此代码将完成这项工作：

这不是一个直接的解决方案，正如我们所说的那样：

CountUnique(): count unique value for a range
GetLastCell4ID(): get last cell row index for an ID value
DeleteSameScenario(): real sub to do the delete job.

Option Explicit


' count unique values list from a range:
'
' ref. https://www.thesmallman.com/list-unique-items-with-vba
'
Function CountUnique(ByVal objRange As Object)
  Dim varVal
  Dim rng As Range, objDict As Object

  Set objDict = CreateObject("scripting.dictionary")

  For Each rng In objRange
    varVal = objDict.Item(rng.Value)
  Next
'
  CountUnique = objDict.Count
'
  Set rng = Nothing
  Set objDict = Nothing
'
End Function

Function GetLastCell4ID(ByVal id As Long, ByVal lFirstCell As Long, ByVal nRows As Long)
   Dim l As Long
   l = Application.WorksheetFunction.CountIf(Range("A" & lFirstCell & ":A" & nRows), id)
   GetLastCell4ID = lFirstCell + l - 1
End Function

Sub DeleteSameScenario()

  Dim iRowStart As Long, iRowEnd As Long, nUnique As Long, nRows As Long

'
' get total initial non empty rows:
  nRows = Cells(rows.Count, "A").End(xlUp).row
  
' loop over ID range:
'
  iRowStart = 2
'
  Do While (iRowStart < nRows)
    iRowEnd = GetLastCell4ID(Range("A" & iRowStart).Value, iRowStart, nRows)
    nUnique = CountUnique(Range("K" & iRowStart, "K" & iRowEnd))
    If (nUnique = 1) Then
      Range("A" & iRowStart & ":A" & iRowEnd).EntireRow.Delete
      nRows = nRows - (iRowEnd - iRowStart + 1)
    Else
      iRowStart = iRowEnd + 1
    End If
  Loop
  
End Sub