distinct lists

[dlythgoe]

Hi all,

I have a large list of names with many duplicates. Alongside these names in another column I have a revenue figure.

How do I first output in a separate list, the top 25 of those names distinctly ordered by rank of the sum of the revenue figures?

Many thanks!!

[sweep]

Hi,

have you tried a pivot table?

[dlythgoe]

Hi,

No - I won't be using a pivot table because this is more complex in the grand scheme of everything I'm doing due to presentation etc....

I can easily filter on the table using tools like this but I'm in a different situation.

So need to be able to return a distinct list of values off the back of a list of duplicates to start with!

Cheers

[dlythgoe]

Figured it out!

You can connect to your own data table as a data connection via ODBC.

Then run SELECT DISTINCT sql on it :D

Being able to run MS SQL on your data tables is immense power that has been around for ages!

[Kenneth Hobson]

If you don't mind, please post your code.

I have used that method using ADO but not as a data query. It is usually pretty fast.

Here is an example where I filled some listbox controls on a sheet.

Private Sub CommandButton1_Click()
  FillLBControl ADOSheet.ListBox1, _
    ThisWorkbook.Path & "\nwind.mdb", _
    "Select Customers.ContactTitle from Customers"
    
  FillLBControl ADOSheet.ListBox2, _
    ThisWorkbook.Path & "\nwind.mdb", _
    "Select Distinct ContactTitle from Customers order by ContactTitle Desc"
    
  FillCBControl ADOSheet.ComboBox1, _
    ThisWorkbook.Path & "\nwind.mdb", _
    "Select Customers.ContactTitle from Customers"
    
  FillCBControl ADOSheet.ComboBox2, _
    ThisWorkbook.Path & "\nwind.mdb", _
    "Select Distinct ContactTitle from Customers order by ContactTitle Desc"
End Sub

Sub FillLBControl(theControl As MSForms.ListBox, mdbName As String, sSQL As String)
  'Requires Reference to Microsoft ActiveX Data Objects 2.8 Library
  'Used for Listbox control for one column only.
  Dim cnt     As New ADODB.Connection
  Dim rst     As New ADODB.Recordset
  Dim rcArray As Variant
  Dim sConnect As String
  sConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & mdbName & ";"
  
  'On Error GoTo CloseADO
   
   'Open connection to the database
  cnt.Open sConnect
   
   'Open recordset and copy to an array
  rst.Open sSQL, cnt
  rcArray = rst.GetRows
   
   'Place data in the Control
  With theControl
      .Clear
      .ColumnCount = 1
      .List = Application.Transpose(rcArray)
      .ListIndex = 0
  End With
   
CloseADO:
   'Close ADO objects
  rst.Close
  cnt.Close
  Set rst = Nothing
  Set cnt = Nothing
End Sub

Here is a Filter/Sort method. I have used this method to do my scratch work in a hidden sheet.

Sub Macro2()
'Code by Ger Plante, http://www.ozgrid.com/forum/showthread.php?t=94136

    Dim my_range As Range
    Dim my_cell As Variant
     
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("C2" _
    ), Unique:=True
    Set my_range = Range("C3", Range("C3").End(xlDown))
    my_range.Sort Key1:=Range("C3"), Order1:=xlAscending, Header:=xlNo, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
    DataOption1:=xlSortNormal
    For Each my_cell In my_range
        MsgBox ("The Year is " & my_cell.Value)
    Next     
End Sub

Another method is to use a Collection or Dictionary to get unique values and then sort.

Here is an array method.

'http://www.excelforum.com/excel-programming/664539-storing-distinct-values.html

Sub UniqueSort()
  Dim a() As Variant
  Dim r As Range
  Set r = Sheet1.Range("A1", Sheet1.Cells(Rows.Count, "A").End(xlUp))
  a = UniqueValues(r)
  a = SortArray(a)
  r.ClearContents
  Sheet1.Range("A1").Resize(UBound(a), 1) = WorksheetFunction.Transpose(a)
End Sub


Sub Test_UniqueValues()
  Dim r As Range, vRange As Variant, s As String
  Set r = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  vRange = UniqueValues(r)
  s = Join(vRange, ";")
  MsgBox s
End Sub

'http://msdn.microsoft.com/en-us/library/aa730921.aspx
'http://www.mrexcel.com/forum/showthread.php?t=329212
Function UniqueValues(theRange As Range) As Variant
    Dim colUniques As New VBA.Collection
    Dim vArr As Variant
    Dim vCell As Variant
    Dim vLcell As Variant
    Dim oRng As Excel.Range
    Dim i As Long
    Dim vUnique As Variant
    Set oRng = Intersect(theRange, theRange.Parent.UsedRange)
    vArr = oRng
    On Error Resume Next
    For Each vCell In vArr
    If vCell <> vLcell Then
        If Len(CStr(vCell)) > 0 Then
             colUniques.Add vCell, CStr(vCell)
        End If
    End If
    vLcell = vCell
    Next vCell
    On Error GoTo 0
 
    ReDim vUnique(1 To colUniques.Count)
    For i = LBound(vUnique) To UBound(vUnique)
      vUnique(i) = colUniques(i)
    Next i
 
    UniqueValues = vUnique
End Function

Sub Test2_UniqueValues()
  Dim a() As Variant
  Dim r As Range
  Set r = Sheet1.Range("A1", Sheet1.Cells(Rows.Count, "A").End(xlUp))
  a = UniqueValues(r)
 'Sheet1.Range("A1").Resize(UBound(a, 1), UBound(a, 2)) = WorksheetFunction.Transpose(a)
  r.ClearContents
  r.Resize(UBound(a), 1) = WorksheetFunction.Transpose(a)
 ' Sheet1.Range("A1").Resize(UBound(a), 1) = WorksheetFunction.Transpose(a)
End Sub

Function SortArray(ByRef MyArray As Variant, Optional Order As Long = xlAscending) As Variant
    Dim w As Worksheet
    Dim r As Range
     
    Set w = ThisWorkbook.Worksheets.Add()
     
    On Error GoTo D1
    Range("A1").Resize(UBound(MyArray, 1), UBound(MyArray, 2)) = WorksheetFunction.Transpose(MyArray)
Continue:
    Set r = w.UsedRange
    If Order = xlAscending Then
      r.Sort Key1:=r.Cells(1, 1), Order1:=xlAscending
      Else
       r.Sort Key1:=r.Cells(1, 1), Order1:=xlDescending
    End If
     
    SortArray = r
     
    Set r = Nothing
    Application.DisplayAlerts = False
    w.Delete
    Application.DisplayAlerts = True
    Set w = Nothing
    
    Exit Function
D1:
  Range("A1").Resize(UBound(MyArray, 1), 1) = WorksheetFunction.Transpose(MyArray)
  On Error GoTo 0
  GoTo Continue
End Function