如果 3 列重复且 1 列为空白，则删除整行

Question

我有 3 列。我需要根据第 1、2、3 列删除具有重复项的行。如果一行包含来自另一行的相同数据但第 2 列为空白，这也将被视为重复。删除第2行空白列，保留数据完整的行。

以黄色突出显示的被认为是重复的，必须删除第 2 列中没有数据的行。

我被困在这里了。

Sub DeleteRows()
    Dim Rng As Range
    Dim i As Long
    Set Rng = ThisWorkbook.ActiveSheet.Range("F:F")
    With Rng
       
        For i = .Rows.Count To 1 Step -1
            If .Item(i) = "" Then
                
                .Item(i).CurrentRegion.RemoveDuplicates Columns:=Array(1,3,)
            End If
        Next i
    End With
End Sub

提前谢谢你！

Answer 1

如果空白单元格删除重复项

• 一些示例数据和/或屏幕截图可能会让更多人了解您的目标。
• RemoveDuplicates 无法为所欲为。
• 相关数据只是Blank Column（6或F）中单元格为空白（Empty，=""，'，...）的范围内的行。
• 重复是指在Duplicate Columns（4, 7, 8 或D, G, H）的所有单元格中的前一行具有相同值的行。

Option Explicit

Sub DeleteDuplicatesIfBlank()
    
    Const dColsList As String = "D,G,H" ' Duplicate Columns List (2 at least)
    Const bCol As String = "F" ' Blank Column
    Const Delimiter As String = "||" ' Dictionary Delimiter
    
    ' Create a reference to the range ('rg').
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    
    ' Write the Duplicate columns to the Duplate Columns Array ('dCols').
    Dim dCols() As String: dCols = Split(dColsList, ",")
    Dim dUpper As Long: dUpper = UBound(dCols)
    
    ' Define the Dictionary ('dict').
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' ignore case i.e. A=a
    
    ' Declare additional variables.
    Dim drg As Range ' Delete Range
    Dim rrg As Range ' Current Row Range
    Dim n As Long ' Duplicate Column Counter
    Dim cString As String ' Current String (created from the Duplicate Columns)
    
    ' Loop through each row ('rrg') of the range.
    For Each rrg In rg.Rows
        ' Only consider the row if its Blank Column is blank.
        If Len(CStr(rrg.Columns(bCol).Value)) = 0 Then
            ' Concatenate the strings from the Duplicate Columns to 'cString'.
            cString = CStr(rrg.Columns(dCols(0)).Value) ' first
            For n = 1 To dUpper ' remainder
                cString = cString & Delimiter & CStr(rrg.Columns(dCols(n)))
            Next n
            If dict.Exists(cString) Then ' duplicate found
                ' Combine the Current Row Range into the Delete Range.
                If drg Is Nothing Then
                    Set drg = rrg
                Else
                    Set drg = Union(drg, rrg)
                End If
            Else ' not a duplicate, so add it to the Dictionary
                dict(cString) = Empty
            End If
        'Else ' The Blank Column is not blank: do nothing.
        End If
    Next rrg
    
    If drg Is Nothing Then Exit Sub ' no duplicates found
    
    ' Delete the rows containing duplicates. Possible data to the right
    ' of the range will not be affected.
    drg.Delete ' for entire rows use drg.EntireRow.Delete
    
End Sub