CODEWITHSUNDEEP
excelvbaadvanced-filter
Hareborn
Hareborn

Reputation: 175

Advanced filters is returning a single duplicate name at both the beginning and end of the created list?

I am attempting to combine four separate list of name into a single list without showing any duplicates. The code below uses the advanced filters to first filter for unique names from each of the four list and then combine them into a single name list. It then again uses advanced filters on the newly created consolidated name list to double check for duplicates and then writes the final list of unique names.

My issue is that the final name list is showing a single duplicate name that appears at both the beginning and at the end list.

Option Explicit

Sub CreateUniqueList()
Dim lastrow As Long

ActiveSheet.Range("d:d").Clear
ActiveSheet.Range("x:x").Clear

    ActiveSheet.Range("g13:g36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("D2"), True

lastrow = Cells(Rows.Count, "d").End(xlUp).Row + 1

    ActiveSheet.Range("i13:i36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("d" & lastrow), True

lastrow = Cells(Rows.Count, "d").End(xlUp).Row + 1

    ActiveSheet.Range("k13:k36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("d" & lastrow), True

lastrow = Cells(Rows.Count, "d").End(xlUp).Row + 1

    ActiveSheet.Range("m13:m36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("d" & lastrow), True

lastrow = Cells(Rows.Count, "d").End(xlUp).Row

    ActiveSheet.Range("d2:d" & lastrow).AdvancedFilter xlFilterCopy, , ActiveSheet.Range("x2"), True
    
ActiveSheet.Range("d:d").Clear

End Sub

I'm sure it is a simple mistake but for the life of me I can't figure it out.

Upvotes: 1

Views: 330

Answers (1)

VBasic2008
VBasic2008

Reputation: 54807

Copy Unique Values From Columns

  • AdvancedFilter will copy the headers, so if the first row is 1, and 1 is found somewhere below, it will remain a duplicate. An idea would be to copy the range from column D to X right before your last AdvancedFilter action and apply a RemoveDuplicates instead.
  • But I've opted for a faster solution using data structures i.e. writing the whole source range to an array, writing the unique values from the designated columns of the source range to a dictionary, writing the values from the dictionary to another array, and finally, writing the values from the array to the destination range. Also, there is no need for a helper column.
Option Explicit

Sub CreateUniqueList()
    
    ' Source
    Const sName As String = "Sheet1"
    Const srgAddress As String = "G13:M36"
    Dim sCols As Variant: sCols = Array(1, 3, 5, 7)
    ' Destination
    Const dName As String = "Sheet1"
    Const dfCellAddress As String = "X2"
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Return the values from the source range ('srg')
    ' in the 2D one-based source array ('sData').
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range(srgAddress)
    Dim sData As Variant: sData = srg.Value
    
    ' Return the unique values from the designated columns ('sCols')
    ' of the source array in a dictionary ('dict')
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    Dim c As Long
    For c = LBound(sCols) To UBound(sCols)
        DictAddColumn dict, sData, sCols(c)
    Next c
    Erase sData

    ' Return the values from the dictionary
    ' in the 2D one-based one-column destination array ('dData').
    Dim dData As Variant: dData = GetColumnDictKeys(dict)
    Set dict = Nothing
    Dim drCount As Long: drCount = UBound(dData, 1)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    With dws.Range(dfCellAddress)
        ' Write the result.
        .Resize(drCount).Value = dData
        ' Clear below.
        .Resize(dws.Rows.Count - .Row - drCount + 1) _
            .Offset(drCount).ClearContents
    End With
        
    MsgBox "Unique list created.", vbInformation
    
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Adds the unique values from a column ('sColumnIndex')
'               of a 2D array ('sData') to an existing dictionary ('dDict').
' Remarks:      Error values and blanks are excluded.
' Remarks:      'ByRef' indicates that the dictionary in the calling procedure
'               will be modified.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAddColumn( _
        ByRef dDict As Object, _
        ByVal sData As Variant, _
        Optional ByVal sColumnIndex As Variant, _
        Optional ByVal DoCount As Boolean = False)
    Const ProcName As String = "DictAddColumn"
    On Error GoTo ClearError

    Dim sKey As Variant
    Dim sr As Long
    For sr = LBound(sData, 1) To UBound(sData, 1)
        sKey = sData(sr, sColumnIndex)
        If Not IsError(sKey) Then
            If Len(CStr(sKey)) > 0 Then
                If DoCount Then
                    dDict(sKey) = dDict(sKey) + 1
                Else
                    dDict(sKey) = Empty
                End If
            End If
        End If
    Next sr

ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the keys from a dictionary ('sDict')
'               in a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnDictKeys( _
    ByVal sDict As Object) _
As Variant
    Const ProcName As String = "GetColumnDictKeys"
    On Error GoTo ClearError
    
    Dim dData As Variant: ReDim dData(1 To sDict.Count, 1 To 1)
    
    Dim sKey As Variant
    Dim dr As Long
    
    For Each sKey In sDict.Keys
        dr = dr + 1
        dData(dr, 1) = sKey
    Next sKey
    
    GetColumnDictKeys = dData
    
ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

EDIT

  • This solution copies the complete ranges' values and applies RemoveDuplicates.
Sub CreateUniqueListCopyByAssignment()
' without helper column
    
    Const cCount As Long = 4
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    Dim srg As Range: Set srg = ws.Range("G13:G36")
    Dim rCount As Long: rCount = srg.Rows.Count
    Dim drg As Range: Set drg = ws.Range("X2").Resize(rCount)
    
    Application.ScreenUpdating = False
    
    ws.Range("X2:X" & ws.Rows.Count).Clear
    
    Dim c As Long
    For c = 0 To cCount - 1
        drg.Offset(c * rCount).Value = srg.Offset(, c * 2).Value
    Next c
    
    drg.Resize(rCount * cCount).RemoveDuplicates 1, xlNo

    Application.ScreenUpdating = True

End Sub
  • This solution is similar to yours, but it applies RemoveDuplicates near the end, mentioned at the top of this post. I think these ranges are too small to harvest the power of AdvancedFilter.
Sub CreateUniqueListQuickFix()
' with helper column
    Application.ScreenUpdating = False
    
    With ActiveSheet
        
        Dim rCount As Long: rCount = .Rows.Count
        Dim lr As Long

        .Range("X2:X" & rCount).Clear
        
        .Range("g13:g36").AdvancedFilter xlFilterCopy, , .Range("D2"), True
        
        lr = Cells(rCount, "D").End(xlUp).Row + 1
        .Range("i13:i36").AdvancedFilter xlFilterCopy, , .Range("D" & lr), True
        
        lr = Cells(rCount, "D").End(xlUp).Row + 1
        .Range("k13:k36").AdvancedFilter xlFilterCopy, , .Range("D" & lr), True
        
        lr = Cells(rCount, "D").End(xlUp).Row + 1
        .Range("m13:m36").AdvancedFilter xlFilterCopy, , .Range("D" & lr), True
        
        lr = Cells(rCount, "D").End(xlUp).Row
        .Range("D2:D" & lr).RemoveDuplicates 1, xlNo
        lr = Cells(rCount, "D").End(xlUp).Row
        .Range("D2:D" & lr).Copy .Range("X2")
        .Range("D2:D" & lr).Clear

    End With

    Application.ScreenUpdating = True

End Sub

Upvotes: 2

Related Questions