VBA unique list from 2 columns

[MikeCook69]

I have two columns of data and I want to create of a list of unique values on another sheet. The data set is not going to be too large, so it doesn't have to be the most efficient code. I'm not sure where to start but any help would be appreciated.

This my original data

A B

1 a
1 b
1 b
2 a
2 b
2 b
3 a
3 a
3 c
3 c


And I want to end up with this copied on another sheet.

A B

1 a
1 b
2 a
2 b
3 a
3 c​

​

​

 

[pvr928]

Hi MikeCook69

Does this suit? Paste it into a Module and change the references to suit.

Option Explicit
Sub GenerateUniqueList()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lLastRow As Long
Dim aDataArray()
Dim i As Integer
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim key As Variant
Set ws1 = Sheet3 '<- change to suit
Set ws2 = Sheet4 '<- change to suit
lLastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row '<- change to suit
aDataArray = Range(ws1.Cells(2, 1), ws1.Cells(lLastRow, 2)) '<- change to suit
ReDim Preserve aDataArray(1 To lLastRow - 1, 1 To 3)
For i = 1 To lLastRow - 1
    aDataArray(i, 3) = aDataArray(i, 1) & aDataArray(i, 2)
Next i
For i = 1 To lLastRow - 1   
    dict(aDataArray(i, 3)) = i
Next i
i = 0
For Each key In dict.Keys
    i = i + 1
    ws2.Cells(i + 1, 1) = Left(key, 1)
    ws2.Cells(i + 1, 2) = Right(key, 1)
Next key
End Sub

Cheers

pvr928

 

[Trebor76]

Hi Mike,

Welcome to MrExcel!!

Here's my attempt:

Option Explicit
Sub Macro1()
    
    Dim wsSource As Worksheet
    Dim wsOutput As Worksheet
    Dim objMyUniqueData As Object
    Dim lngLastRow As Long
    Dim rngMyCell As Range
    
    Application.ScreenUpdating = False
    
    Set wsSource = Sheets("Sheet1") 'Sheet name with raw data. Change to suit if necessary.
    Set wsOutput = Sheets("Sheet2") 'Sheet name to output unique list. Change to suit if necessary.
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")

    lngLastRow = wsSource.Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    For Each rngMyCell In wsSource.Range("A2:A" & lngLastRow)
        If Len(rngMyCell) > 0 And Len(rngMyCell.Offset(0, 1)) > 0 Then
            If objMyUniqueData.Exists(CStr(rngMyCell) & rngMyCell.Offset(0, 1)) = False Then
                objMyUniqueData.Add CStr(rngMyCell) & rngMyCell.Offset(0, 1), Array(CStr(rngMyCell), CStr(rngMyCell.Offset(0, 1)), CStr(rngMyCell) & rngMyCell.Offset(0, 1))
            End If
        End If
    Next rngMyCell
    
    wsOutput.Range("A2:B" & objMyUniqueData.Count + 1) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(objMyUniqueData.Items)) '1 added to account for header row
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[MikeCook69]

Thanks for the replies. I was able to modify Roberts to work. Now I need to add an additional column to the output that is not part of the unique parameter check. Essentially the first code from Robert is if A & B are unique, return A,B. Now I need if A & B are unique return A,B,C. I'm new to using arrays and I still don't know all the parameters. This is my attempt but I get an error that "the key is already associated with an element of this collection". Any help is appreciated.

Sub Create_list()
    
    Dim wsSource As Worksheet
    Dim wsOutput As Worksheet
    Dim objMyUniqueData As Object
    Dim lngLastRow As Long
    Dim rngMyCell As Range
    
    
    Set wsSource = Sheets("Master") 'Sheet name with raw data.
    Set wsOutput = Sheets("Current") 'Sheet name to output unique list.   
            
    
    Application.ScreenUpdating = False
    
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")
    lngLastRow = wsSource.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    For Each rngMyCell In wsSource.Range("C5:C" & lngLastRow)
        If Len(rngMyCell.Offset(0, 17)) = 0 Then
       
            If objMyUniqueData.exists(CStr(rngMyCell) & rngMyCell.Offset(0, 5)) = False Then
                objMyUniqueData.Add CStr(rngMyCell) & rngMyCell.Offset(0, 5) & rngMyCell.Offset(0, 2), Array(CStr(rngMyCell), CStr(rngMyCell.Offset(0, 5)), CStr(rngMyCell.Offset(0, 2)), CStr(rngMyCell) & rngMyCell.Offset(0, 5) & rngMyCell.Offset(0, 2))
            End If
        
        End If
    Next rngMyCell
    
    wsOutput.Range("A4:C" & objMyUniqueData.Count + 3) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(objMyUniqueData.Items)) '3 added to account for header rows
    
    Application.ScreenUpdating = True
    
   'Sets Output Range
  
    Dim rngOutput As Range
    Dim rngOutputRowC As Range
    Dim lngOutputLR As Long
    
    
    lngOutputLR = wsOutput.Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rngOutput = wsOutput.Range("A4:C" & lngOutputLR)
    Set rngOutputRowC = wsOutput.Range("C4:C" & lngOutputLR)
    
    
  
End Sub

 

[Trebor76]

The error is because the code checks for uniqueness across columns A and B before adding it the scripting dictionary. However, you're adding three columns to the array the uniqueness of which has not been checked and there's obviously doubling up and hence the error message.

This should do the job:

Option Explicit
Sub Macro1()
    
    Dim wsSource As Worksheet
    Dim wsOutput As Worksheet
    Dim objMyUniqueData As Object
    Dim lngLastRow As Long
    Dim rngMyCell As Range
    Dim lngPasteRow As Long
    
    Application.ScreenUpdating = False
    
    Set wsSource = Sheets("Sheet1") 'Sheet name with raw data. Change to suit if necessary.
    Set wsOutput = Sheets("Sheet2") 'Sheet name to output unique list. Change to suit if necessary.
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")

    lngLastRow = wsSource.Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    wsSource.Range("A5:C" & lngLastRow).Copy Destination:=wsOutput.Range("A5")
    
    wsOutput.Range("A5:C" & lngLastRow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

    For Each rngMyCell In wsSource.Range("A5:A" & lngLastRow)
        If Len(rngMyCell) > 0 And Len(rngMyCell.Offset(0, 1)) > 0 Then
            If objMyUniqueData.Exists(CStr(rngMyCell) & rngMyCell.Offset(0, 1)) = False Then
                objMyUniqueData.Add CStr(rngMyCell) & rngMyCell.Offset(0, 1), Array(CStr(rngMyCell), CStr(rngMyCell.Offset(0, 1)), CStr(rngMyCell) & rngMyCell.Offset(0, 1))
                If lngPasteRow = 0 Then
                    lngPasteRow = 5 'Initial output row. Change to suit if necessary.
                Else
                    lngPasteRow = lngPasteRow + 1
                End If
                wsSource.Range("A" & rngMyCell.Row & ":C" & rngMyCell.Row).Copy Destination:=wsOutput.Range("A" & lngPasteRow)
            End If
        End If
    Next rngMyCell
    
    Application.ScreenUpdating = True

End Sub

Excel 2007 introduced the remove duplicates functionality you can also achieve the same by this more succinct code:

Option Explicit
Sub Macro2()

    Dim wsSource As Worksheet
    Dim wsOutput As Worksheet
    Dim lngLastRow As Long
        
    Application.ScreenUpdating = False
    
    Set wsSource = Sheets("Sheet1") 'Sheet name with raw data. Change to suit if necessary.
    Set wsOutput = Sheets("Sheet2") 'Sheet name to output unique list. Change to suit if necessary.
    
    lngLastRow = wsSource.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    'Works on the range A5:C[lngLastRow]
    wsSource.Range("A5:C" & lngLastRow).Copy Destination:=wsOutput.Range("A5")
    wsOutput.Range("A5:C" & lngLastRow).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert