PDA

View Full Version : Scripting dictionary



lifeson
01-20-2009, 06:53 AM
Quick question about scripting dictionarys
Is the dictionary object only 1 column?

I am looking at using a dictionary to create a unique list from a recordset to poulate a 2 column combo box
Or, is there a way of creating a unique list when stepping through a recordset?

Set rst = New ADODB.recordSet
rst.Open Source:=qry, ActiveConnection:=Connection

Do While Not rst.EOF
finPackID = rst.Fields("FinPackID").Value
finPackDesc = rst.Fields("Description").Value
'something like
dic.Add finPackID, finPackDesc

rst.MoveNext
Loop

'with me.cboFinancePackage
'.rowsource = dic
'end with

Kenneth Hobs
01-20-2009, 07:16 AM
Use the word DISTINCT in your sql string.

lifeson
01-20-2009, 08:10 AM
Kenneth
This is my SQL string

SELECT TblProdFinPackLink.ProductType, TblProdFinPackLink.FinPackId, TblProdFinPackLink.PlanRanking, TblProdFinPackLink.ActiveFlag, TblFinancePackageList.Description, TblFinancePackageList.ActiveToDate
FROM TblProdFinPackLink INNER JOIN TblFinancePackageList ON TblProdFinPackLink.FinPackId=TblFinancePackageList.FinancePackageID
GROUP BY TblProdFinPackLink.ProductType, TblProdFinPackLink.FinPackId, TblProdFinPackLink.PlanRanking, TblProdFinPackLink.ActiveFlag, TblFinancePackageList.Description, TblFinancePackageList.ActiveToDate
HAVING (((TblProdFinPackLink.ProductType)="CHA" Or (TblProdFinPackLink.ProductType)="CHP" Or (TblProdFinPackLink.ProductType)="CHB") AND ((TblProdFinPackLink.ActiveFlag)=True) AND ((TblFinancePackageList.ActiveToDate)>Now()))
ORDER BY TblProdFinPackLink.PlanRanking;

and if I try DISTINCT like this:

SELECT DISTINCT TblProdFinPackLink.ProductType, TblProdFinPackLink.FinPackId, TblProdFinPackLink.PlanRanking, TblProdFinPackLink.ActiveFlag, TblFinancePackageList.Description, TblFinancePackageList.ActiveToDate
FROM TblProdFinPackLink INNER JOIN TblFinancePackageList ON TblProdFinPackLink.FinPackId=TblFinancePackageList.FinancePackageID
GROUP BY TblProdFinPackLink.ProductType, TblProdFinPackLink.FinPackId, TblProdFinPackLink.PlanRanking, TblProdFinPackLink.ActiveFlag, TblFinancePackageList.Description, TblFinancePackageList.ActiveToDate
HAVING (((TblProdFinPackLink.ProductType)="CHA" Or (TblProdFinPackLink.ProductType)="CHP" Or (TblProdFinPackLink.ProductType)="CHB") AND ((TblProdFinPackLink.ActiveFlag)=True) AND ((TblFinancePackageList.ActiveToDate)>Now()))
ORDER BY TblProdFinPackLink.PlanRanking;

I get the same results. The data is badly formatted but I cant change that unfortunately
The results returned are in this example:

CHA - BGFFP - Flexible Finance Plan
CHB - BGFFP - Flexible Finance Plan
CHB - CASH - CASH

I only want to show in my combo

BGFFP - Flexible Finance Plan
CHB - CASH

Kenneth Hobs
01-20-2009, 08:28 AM
You should have the sql use DISTINCT on an AS variable that trims the first 6 characters in that case.

Otherwise, I guess you could clear a hidden sheet contents and insert your data. You can then get your uniques from it in various ways. You may want to resort your data if you strip characters and don't sort in your sql by the AS variable. Here is how I did it for a userform's combobox.
Private Sub UserForm_Initialize()
Dim e As Variant
For Each e In SortArray(UniqueValues(Sheet1.Range("A1:F9")))
ComboBox1.AddItem e
Next e
End Sub

'Similar to, http://vbaexpress.com/forum/showthread.php?t=21265
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 Resume Next
Range("A1").Resize(UBound(MyArray, 1), 1) = WorksheetFunction.Transpose(MyArray)
Range("A1").Resize(UBound(MyArray, 1), UBound(MyArray, 2)) = WorksheetFunction.Transpose(MyArray)
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
End Function

'http://www.mrexcel.com/forum/showthread.php?t=329212
Public 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


Here is a dictionary method though collection methods are similar.
Sub Deletedups()
Dim a, V, z
With Range("a1:a" & Range("a" & Rows.Count).End(xlUp).Row)
a = .Value
With CreateObject("scripting.dictionary")
.comparemode = vbTextCompare
For Each V In a
If Not IsEmpty(V) And Not .exists(V) Then .Add V, Nothing
Next
z = .keys
End With
.ClearContents
.Resize(UBound(z) + 1).Value = Application.Transpose(z)
End With
End Sub