僅從當前選擇（不是整個表）中洗掉重復項Excel-VBA

我試圖從我的表中的某個范圍中洗掉重復的聯系人，但它每次運行時都會從整個表中洗掉重復項，而不僅僅是當前選擇。

這不是我想要的，因為同一個聯系人可以在表中的不同專案下。我只是不想在同一個專案下重復該聯系人。

這是我的意思的示例，但實際上有更多的聯系和專案。它應該只從最后一個專案輸入中洗掉重復的 Contact 9。因此，不應洗掉 Contact 1 和 Contact 2，但根據現在的書寫方式，它們是。

這是我的代碼

Dim rng As Range

'Rowies is defined elsewhere as the top row of the last entered project, in this sample it would be A8
Rowies.Select

Range(Selection, Selection.Offset(0, 3)).Select

Set rng = Range(Selection, Selection.End(xlDown))

'i have duplicates removed based upon their email addresses.
rng.RemoveDuplicates Columns:=4, Header:=xlNo

我不太確定我做錯了什么，我瀏覽了檔案并且無法弄清楚。

任何幫助，將不勝感激！

uj5u.com熱心網友回復：

這將使用字典洗掉專案中的所有重復行。它不依賴于選擇一個范圍，它只是貫穿所有專案。

我假設您的資料從 A 列開始，B 列是最長的列。

Sub removeDupes()
    Dim i As Long
    Dim lr As Long
    
    Dim dict As Object
    Dim project As String
    
    Dim delrng As Range
    Set dict = CreateObject("Scripting.Dictionary") 'Reference is Microsoft Scripting Runtime if you want early binding
    
    With Sheets("Sheet1") 'Change as needed
        lr = .Cells(.Rows.Count, 2).End(xlUp).Row
        
        For i = 2 To lr
            If .Cells(i, 1).Value <> "" Then
                project = .Cells(i, 1).Value
            End If
            
            If Not dict.exists(project & .Cells(i, 2).Value) Then
                dict.Add project & .Cells(i, 2).Value, ""
            Else
                If delrng Is Nothing Then
                    Set delrng = .Rows(i).EntireRow
                Else
                    Set delrng = Union(delrng, .Rows(i).EntireRow)
                End If
            End If
        Next i
        
        delrng.Delete
    End With
                    
End Sub

uj5u.com熱心網友回復：

使用洗掉連續范圍中的重復項 RemoveDuplicates

• 假設（表）范圍是連續的（沒有空行或列），并且它從A1一行開始并具有標題。
• 假設每個專案都以Project column.
• 只有Dupe column用于將行限定為重復。
• 僅洗掉范圍的行（不是整行），不會影響右側的單元格。
• 由于需要洗掉空行，所以從下往上依次進行處理。如果每個專案范圍有多于一行，首先會進行檢查。如果是，則洗掉任何重復項。如果有任何洗掉（清除專案范圍行），至少復制列中的最后一個單元格變為空。然后使用此資訊洗掉出現的空專案范圍行。

Option Explicit

Sub RemoveProjectDuplicates()
    
    Const wsName As String = "Sheet1"
    Const pCol As Long = 1 ' Project Column
    Const dCol As Long = 4 ' Dupe Column
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion ' Table Range
    Dim fRow As Long: fRow = rg.Row   1 ' First Data Row
    Dim plRow As Long: plRow = rg.Rows.Count ' Project Last Row
    
    Dim prg As Range ' Project Range
    Dim pdrg As Range ' Project Delete Range
    Dim plCell As Range ' Project Last Cell
    Dim dlCell As Range ' Dupe Last Cell
    Dim pfRow As Long ' Project First Row
    Dim pdfRow As Long ' Project Delete First Row
    
    Application.ScreenUpdating = False
    
    ' Loop backwards.
    Do
        Set plCell = ws.Cells(plRow, pCol)
        If IsEmpty(plCell) Then ' project has more than one row
            ' Remove duplicates.
            pfRow = plCell.End(xlUp).Row
            Set prg = rg.Rows(pfRow).Resize(plRow - pfRow   1)
            prg.RemoveDuplicates dCol, xlNo
            ' Delete (trailing) empty project rows.
            Set dlCell = plCell.EntireRow.Columns(dCol)
            If IsEmpty(dlCell) Then ' duplicates found and removed
                pdfRow = dlCell.End(xlUp).Row   1
                Set pdrg = prg.Resize(plRow - pdfRow   1).Offset(pdfRow - pfRow)
                pdrg.Delete xlShiftUp
            'Else ' no duplicates found, no need to delete
            End If
        Else ' project has one row only
            pfRow = plRow
        End If
        plRow = pfRow - 1
    Loop Until pfRow = fRow
    
    Application.ScreenUpdating = True
    
End Sub

uj5u.com熱心網友回復：

使用 Collection 物件而不是 Dictionary。步驟 1 突出顯示重復項，步驟 2 洗掉突出顯示的專案。（未在 Mac 上測驗）

Option Explicit

Sub RemoveDups()

    Const COL_DUPL = "Email"
    Const COL_PROJECT = "Project Name"

    Dim tbl As ListObject, r As Long, lastrow As Long
    Dim c1 As Long, c2 As Long, i As Long, n As Long
    Dim col As Collection

    ' table
    Set tbl = ActiveSheet.ListObjects("Table1")
    With tbl
        c1 = .ListColumns(COL_PROJECT).Index
        c2 = .ListColumns(COL_DUPL).Index
    End With
    
    With tbl.DataBodyRange
         ' step 1 mark duplicates
        lastrow = .Rows.Count
        For r = 1 To lastrow
            If .Cells(r, c1) = "" Then
                ' mark
                If IsDup(col, .Cells(r, c2)) Then
                    .Cells(r, c2).Interior.Color = vbYellow
                    n = n   1
                Else
                    .Cells(r, c2).Interior.Pattern = xlNone
                End If
            Else
               Set col = New Collection
               col.Add Trim(.Cells(r, c2))
            End If
        Next
     
        ' step 2 delete
        If n > 0 Then
            If MsgBox("Delete " & n & " duplicates ?", vbYesNo) = vbYes Then
               For r = lastrow To 1 Step -1
                   If .Cells(r, c2).Interior.Color = vbYellow Then
                       .Rows(r).Delete
                   End If
               Next
            End If
            MsgBox "Done", vbInformation
        Else
            MsgBox "No duplicates", vbInformation
        End If
     End With
     
End Sub

Function IsDup(ByRef col As Collection, item As String) As Boolean
    Dim i As Long, v As Variant
    IsDup = False
    item = Trim(item)
    For Each v In col
        If item = v Then
            IsDup = True
            Exit For
        End If
    Next
    If Not IsDup Then col.Add item
End Function

標籤：擅长 vba

上一篇：用特定值填充空白單元格超過100,000行

下一篇：從模板添加作業簿并更改其名稱