Excel VBA - 如果范围内的单元格值相同，则删除整行

Question

The screenshot detailing the worksheet layout is attached:

Question: How do I delete the entire rows, if all values in column “Scenario” or column K are the same value for the same ID, found in the column “ID” or column A?

For instance, rows with ID “1” would be deleted since the row values under the column “Scenario” are the same. But rows with ID “2” will be kept since the row values under the column “Scenario” are different.

The number of ID rows remain fixed at 16, for each ID. This means ID 1 will take 16 rows, ID 2 will also take 16 rows, and so on.

Answer 1

This code will do the job, if you put it in you Worksheet private module:

It's not a straight forward solution, as we call those routines:

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