VBA Dynamic way to copy and paste unique values

Hi,

I have a ever changing column of data (in no of rows). The starting point is given to C2. In this column I have the following values to pick a few:

BB
NT
BB
NO
CB
LE
WO
WO

What I want to do is consolidate these values and paste under the existing values in column C (previously Ive used Selection.End(xlDown).Offset(1, 0).Select to find the end.

My problems are the following:
1. Consolidate does not work since it needs to specify my workbooks directory and sheet which will be changing from user to user and the sheet is created in the macro so it is not given a specific name.
2. Advance filter copy Uniques does not work for some reason, I get duplicates trying to use this function (these duplicates does not appear when i manually try consolidation).

As I said I can not specify a certain range however would work to choose entire C:D since rest is empty.

Does anyone have a good idea how to solve this?

Many thank you! I am sooooo stuck

I'm not for sure I understood your request.
If I did, then:
Backup your data.
Copy the code below to a standard module (if you don't know how, ask).
Run: Run_GetUniqueValues

It was unclear to me whether you wanted a list of all unique values from both columns C & D (or just C).

Thus in the code below you will see both:

    Set rg = Range("C2:C" & nLastRow)
    ' Set rg = Range("C2:D" & nLastRow)

For both C & D, remove the apostrophe and add it to the line above.

The function: GetUniqueValues collects unique values from any range and stores it in a string separated by the vbCR character. Then Run_GetUniqueValues puts these values in a string array.

You didn't mention if you wanted these values sorted. I added a Bubble sort function to sort these values.

Then leaving an empty row, I copied these values below the previously last row of data in column C.

Function GetUniqueValues(rg As Range) As String
    Dim vArray As Variant, i As Long, j As Long, sList As String
    vArray = rg.Value
    sList = vbCr
    For i = LBound(vArray, 1) To UBound(vArray, 1)
        For j = LBound(vArray, 2) To UBound(vArray, 2)
            If InStr(1, sList, vbCr & vArray(i, j) & vbCr) = 0 Then
                sList = sList & vArray(i, j) & vbCr
            End If
        Next j
    Next i
    If Len(sList) > 2 Then
        GetUniqueValues = Mid$(sList, 2, Len(sList) - 2)
    End If
End Function

Function BubbleSortsArray(ByRef sArray() As String)
    Dim i As Long, j As Long, s As String
    
    For i = LBound(sArray) To UBound(sArray) - 1
        For j = i + 1 To UBound(sArray)
            If sArray(i) > sArray(j) Then
                s = sArray(j)
                sArray(j) = sArray(i)
                sArray(i) = s
            End If
        Next j
    Next i
End Function

Sub Run_GetUniqueValues()
    Dim rg As Range, sArray() As String, nLastRow As Long, i As Long
    
    nLastRow = Cells(Rows.Count, "C").End(xlUp).Row
    
    Set rg = Range("C2:C" & nLastRow)
    ' Set rg = Range("C2:D" & nLastRow)
    sArray = Split(GetUniqueValues(rg), vbCr)
    BubbleSortsArray sArray
    For i = LBound(sArray) To UBound(sArray)
        Cells(nLastRow + 2 + i, "C") = sArray(i)
    Next i
End Sub

Dear StevenM
Is is possible to sort the values based on alphanumerically by using your Function BubbleSortsArray(ByRef sArray() As String) fucntion.


Thanks and regards,

Sudhakar

Your

Hi Steven,

Thank you so much for your reply. Late last evening I actually made it work using the following:

'   Copy all and remove duplicates
    Range("B2:C2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Range("M1").Select
    ActiveSheet.Paste
    Columns("M:N").Select
    Application.CutCopyMode = False
    ActiveSheet.Range("$M$1:$N$1000000").RemoveDuplicates Columns:=2, Header:=xlNo

It is definately not the most effective way but for my purpose it works fine

Thank you!

Joakim

This is a little more efficient:

Sub MoveUnique()
With range("B1").CurrentRegion.Resize(, 2)
    .RemoveDuplicates 2, xlNo
    range("M1").Resize(.Rows.Count, 2).Value = .Value
End With
End Sub

The problem with that kyle is that I dont want to remove the duplicates from the original data set, hence my copy into new area. I want to keep them in the original table just creating a "new set" with unique values so I can SUMIF from the above. (Yes it seems awkward to do it this way but the accounting system demands the format to be in this way)

Joakim

No probs, just switch the code round a bit

Sub MoveUnique()
With range("B1").CurrentRegion.Resize(, 2)
    range("M1").Resize(.Rows.Count, 2).Value = .Value
    range("M1").Resize(.Rows.Count, 2).RemoveDuplicates 2, xlNo
End With
End Sub

This is helpful. However, if there was a third column with different numeric values, how would I have it sum the values from that column in all of the duplicate rows into the consolidated one?