Msgbox returns unique values from column

[Maverick_777]

Guys,
I need to know if there is a way to run a macro which checks the values of a column and returns the list of the unique values in the message portion of the inputbox for the user to choose from. If it maters, there will never be more than 6 unique values.

Either that or can the input box be set to loop if the value inputed is not found?
e.g. I input the value of 22, and there is no 22 found in any cell of the column being checked.

All thoughts welcomed and appreciated...

 

[Trebor76]

Hi Maverick_777,

Try the following (just change the range to suit):

Sub Macro1()

    Dim lngLastRow As Long
    Dim rngCell As Range, _
        rngMyData As Range
    Dim strUniqueList As String
        
    'Assumes the dataset is from A2 to A[whatever the last row in Column A is].
    'Change to suit
    lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Set rngMyData = Range("A2:A" & lngLastRow)
    
    Application.ScreenUpdating = False
    
    For Each rngCell In rngMyData
        If Evaluate("COUNTIF(" & rngMyData.Address & ", " & rngCell.Address & ")") = 1 Then
            If strUniqueList = "" Then
                strUniqueList = rngCell.Value
            Else
                strUniqueList = strUniqueList & vbNewLine & rngCell.Value
            End If
        End If
    Next rngCell
    
    Application.ScreenUpdating = True
    
    MsgBox strUniqueList

End Sub

HTH

Robert

 

[Maverick_777]

Thanks for the quick reply Robert. THe code ended up returning the final value on the list. My hope is that it would return each of the unique values. example: Column A includes the following data. I would want 26, 33, and 44 returned... Any thoughts?

A
header cell
26
26
26
26
33
33
33
33
44

 

[sulakvea]

sorry for this crap - only have couple minutes to post this just gonna give you an idea (if i understood it correctly)

cant you have a combo box instead? if so,

for each MyRange in Range("A:A")
 if application.countif(A:A,MyRange.value) = 1 then
  ComboBox1.additem(MyRange.value)
 end if
next

 

[Trebor76]

Hi Maverick_777,

Sorry, my misunderstanding of what you meant by unique (in your example 44 is actually the only unique number). That said, try:

Sub Macro1()

    Dim lngLastRow As Long
    Dim rngCell As Range, _
        rngMyData As Range
    Dim clnMyList As New Collection
    Dim varMyList As Variant
    Dim strMyList As String
        
    'Assumes the dataset is from A2 to A[whatever the last row in Column A is].
    'Change to suit
    lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Set rngMyData = Range("A2:A" & lngLastRow)
    
    Application.ScreenUpdating = False
    
    On Error Resume Next 'Need to ignore errors as a Collection can only contain unique values
        For Each rngCell In rngMyData
            clnMyList.Add Item:=rngCell.Value, Key:=CStr(rngCell.Value)
        Next rngCell
    On Error GoTo 0 'Nullify error handler
    
    For Each varMyList In clnMyList
        If strMyList = "" Then
            strMyList = varMyList
        Else
            strMyList = strMyList & vbNewLine & varMyList
        End If
    Next varMyList
    
    MsgBox strMyList
    
    Application.ScreenUpdating = True
    
End Sub

HTH

Robert

 

[Maverick_777]

Thanks again Robert, my fault for not clarifying what I was attempting to do...

 

[Trebor76]

That's fine - I'm glad it all worked out

 

[Maverick_777]

Hi guys,
Trebor provided me the code below. It has worked great until recently. A problem has developed where there are more items to select from than I thought.

At this point when the input box appears, there is a lot of blank space and it expands to beyond the bottom of the page so I can no longer see the data that is supposed to appear and can not see the input section.

Any idea how to keep the input box a manageable size and have the data start at the top???

Thanks in advance gurus...

 

[Maverick_777]

Well as usual it was operator error. Problem fixed.

Thanks anyway...

 

[ProgramUser]

Hi Maverick_777,

Sorry, my misunderstanding of what you meant by unique (in your example 44 is actually the only unique number). That said, try:

Sub Macro1()

    Dim lngLastRow As Long
    Dim rngCell As Range, _
        rngMyData As Range
    Dim clnMyList As New Collection
    Dim varMyList As Variant
    Dim strMyList As String
        
    'Assumes the dataset is from A2 to A[whatever the last row in Column A is].
    'Change to suit
    lngLastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Set rngMyData = Range("A2:A" & lngLastRow)
    
    Application.ScreenUpdating = False
    
    On Error Resume Next 'Need to ignore errors as a Collection can only contain unique values
        For Each rngCell In rngMyData
            clnMyList.Add Item:=rngCell.Value, Key:=CStr(rngCell.Value)
        Next rngCell
    On Error GoTo 0 'Nullify error handler
    
    For Each varMyList In clnMyList
        If strMyList = "" Then
            strMyList = varMyList
        Else
            strMyList = strMyList & vbNewLine & varMyList
        End If
    Next varMyList
    
    MsgBox strMyList
    
    Application.ScreenUpdating = True
    
End Sub

HTH

Robert

Hi Guy's,

I'd like to begin with offering many thanks to all participants of the Mr. Excel forum...! I have been following his forum for years and the forum has become a real resource for me and my code. This is next to my first post requesting help on what can only be known as Elementary! so please be patient with me

Much like Maverick_777's original post, I too am having some issues with returning the information I require form the message box function. I'll start with what I am experiencing and then what results I require.

Windows 8.1
Office - 2013

Problem
I have written successful code (please see below) for finding and removing duplicate values from a very large range of data (16 columns with 10,000 + rows), this bit is fine. Using the 'Remove Duplicates' excel function is fine too and the results it offers is excellent, such as this message box;
'1,873 duplicate values found and removed; 8,345 unique values remain.'

I tried cheating and recorded a macro using the Remove Duplicates function however, the VBA results inconveniently omits the code I require! I can't use this excel function as I require much deeper analysis of the data however and must use VBA, I am attempting to write the code that matches the Excel result through it's own 'Remove Duplicates' function whereby it offers a msgbox showing the results -

Example Excel Dialog
'1,873 duplicate values found and removed; 8,345 unique values remain.'

Code Snippet

Sub CopyRemoveDupe()

'Speed up execution
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'my range of data
Range("A4:T10034").Copy Range("X4:AR10034")
Range("X4").Select
    ActiveSheet.Range("$X$4:$AR$10034").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, _
        6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20), Header:=xlYes


' close and restart apps
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

'my message box
MsgBox "Data Copied & Duplicates Removed!", vbInformation


End Sub

My Requirement
I require that the code reveals/shows;

1. How many duplicates were discovered in range (show in msgbox);
2. How many unique values remain in range (show is same msgbox as point one above);
3. Use a second pop-up msgbox to allow user to answer yes/no to copy the results of the 'Find Duplicates' and 'Unique Values Remaining' values and paste to same open and active worksheet.

Hoping someone may be of assistance.

Thanks in advance,

ProgramUser