Return Unique values corresponding to another column in VBA

Question

I am relatively new to VBA, and any help to get this problem solved will be greately appreciated!

I want Excel to look at two columns of text values, and only return the unique ones, for both columns. But I want the two columns to "correspond" to one another, so that the unique values for the first column is returned, and the unique values corresponding to each of the unique values in that column is returned next to it.

I.e. if the columns are the following:

Column 1: a a a d d g g g g 

And the second column's values are

Column 2: 3 3 2 1 1 7 8 8 9 

I would like to first look at column 1. Here, the first unique value is a. Then, take all the unique values in column 2 (i.e. 3 and 2). So (1,1)=a, (1,2)=3, (2,2)=2 and (2,1)=empty. Then, below, is the next unique value, so (3,1)=d, (3,2)=2, (4,1)=empty and (4,2)=1. Then (5,1)=g, and (5,2)=7, (6,1)=empty, (6,2)=8, (7,1)=empty, and (7,2)=9.

It's a little tricky to explain, but I hope it is still possible to get the point!

Thank you!

Answer 1

This code will do that for you

Option Explicit

Sub Main()

    Dim r1 As Range
    Set r1 = Application.InputBox(prompt:="Select first range", Type:=8)

    Dim r2 As Range
    Set r2 = Application.InputBox(prompt:="Select second range", Type:=8)

    If r1.Rows.Count <> r2.Rows.Count Then
        MsgBox "ranges aren't equal in rows, restart the macro!", vbCritical
        Exit Sub
    End If

    ReDim arr(0) As String
    Dim i As Long
    For i = 1 To r1.Rows.Count
        arr(UBound(arr)) = r1.Rows(i) & "###" & r2.Rows(i)
        ReDim Preserve arr(UBound(arr) + 1)
    Next i
    RemoveDuplicate arr
    ReDim Preserve arr(UBound(arr) - 1)

    With Sheets(2)
        .Activate
        .Columns("A:B").ClearContents

        For i = LBound(arr) To UBound(arr)
            .Range("A" & i + 1) = Split(arr(i), "###")(0)
            .Range("B" & i + 1) = Split(arr(i), "###")(1)
        Next i

        For i = .Range("A" & .Rows.Count).End(xlUp).Row To 2 Step -1
            If StrComp(.Range("A" & i).Offset(-1, 0), .Range("A" & i), vbTextCompare) = 0 Then
                .Range("A" & i) = vbNullString
            End If
        Next i
    End With

End Sub


Sub RemoveDuplicate(ByRef StringArray() As String)
    Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
    If (Not StringArray) = True Then Exit Sub
    lowBound = LBound(StringArray): UpBound = UBound(StringArray)
    ReDim tempArray(lowBound To UpBound)
    cur = lowBound: tempArray(cur) = StringArray(lowBound)
    For A = lowBound + 1 To UpBound
        For B = lowBound To cur
            If LenB(tempArray(B)) = LenB(StringArray(A)) Then
                If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
            End If
        Next B
        If B > cur Then cur = B
    tempArray(cur) = StringArray(A)
    Next A
    ReDim Preserve tempArray(lowBound To cur): StringArray = tempArray
End Sub

---

What happens is you are asked to select each column with your mouse. So assuming your spreadsheet looks somehow like below picture then select your two desired columns. First column and then you will be asked for the second one. (select whats in red)

Repeat for the second column and your results will be reprinted in Sheet2