Scripting.Dictionary Code Returning Incorrect Results

[NeedForExcel]

Hi,

I am trying out this code on the attached file -

Sub ScrpDict()

    Dim Dict As Scripting.Dictionary, R As Variant
    Set Dict = New Scripting.Dictionary
    
    With Dict
        For Each R In Range("A2:A17")
            If R <> "" Then .Item(R) = Empty
        Next R
        MsgBox .Count
    End With
    
End Sub

However, even when I am using the .Item() property, it is still not returning unique values.

I want to get the unique values on the D Column..

[NeedForExcel]

Got it..

For Each R In Range("A2:A17") should have been For Each R In Range("A2:A17").Value

Marking the thread solved..

[Kyle123]

You also need to check whether the key already exists or you'll start running into errors

[NeedForExcel]

You also need to check whether the key already exists or you'll start running into errors

But wouldn't using .item() replace the key if it already existed?

I also wanted to know the best way (Avoiding Loops) to spit out these unique values to say column F!

[skywriter]

You could also write it this way.

You will not get an error if the key exists if written in this form.

The way you wrote it originally will not error if the key exists either.

Sub ScrpDict()

    Dim Dict As Scripting.Dictionary, R As Range
    Set Dict = New Scripting.Dictionary
    
    With Dict
        For Each R In Range("A2:A17")
            If R.Value <> "" Then .Item(R.Value) = Empty
        Next R
        MsgBox .Count
    End With
  End Sub

[NeedForExcel]

You could also write it this way.

So does R.Value & only R makes the difference?

I also wanted to know the best way (Avoiding Loops) to spit out these unique values to say column F!

[skywriter]

But wouldn't using .item() replace the key if it already existed?

Remember with this method what you are doing is manipulating the item. You are saying with the item that belongs to this key, change the value of the item.

If the key doesn't exist it adds it and gives the value you state to the item.

If it does exist you are only saying change the value of the item that is paired with this already existing key.

[skywriter]

You could use transpose, but transpose has a limit of 65,536 rows. If you have less than that you are okay.

Sub ScrpDict()

    Dim Dict As Scripting.Dictionary, R As Range
    Set Dict = New Scripting.Dictionary
    
    With Dict
        For Each R In Range("A2:A17")
            If R.Value <> "" Then .Item(R.Value) = Empty
        Next R
        MsgBox .Count
    End With
    Range("B1").Resize(Dict.Count, 1) = Application.Transpose(Dict.keys)
    
  End Sub

[Kyle123]

The biggest bottleneck is that you're looping through a range. Loops aren't bad, looping through worksheet cells is, every time you access the worksheet, it's like hitting the brakes in a car.

Also don't loop through arrays with a for each x in y construct, use that for collections, for arrays you should be using for x to y and accessing by index.

Finally as sky writer says, you can use transpose but ymmv it tends to be slow (much slower than a loop for large data sets) and has limits on the number of values it will transpose.

Re the item, yes but that's not a good thing really. Everytime you update or add to a dictionary I think it re-indexes (which isn't good for performance) that's why it has an exists property so you can check before adding something

[jindon]

NeedForExcel

Remember, when you loop though the range with Dictionary, you can not avoid Value property.

.Item(R.Value) = Empty

[skywriter]

After Kyle's post I did a little experiment.

I copied some data with lots of duplicates all the way down to 1 million rows.

I ran my original code that did not check if the key exists.
I did not time it, but I would guess that it took around 3 seconds.

I then ran the .exists code on the same 1 million rows and I would guess it took just under 2 seconds.

I then put everything in an array and looped the array with the .exists and it was very fast. I would guess under a second.

Kyle thanks for the information.

[NeedForExcel]

I then put everything in an array and looped the array with the .exists and it was very fast. I would guess under a second.

Can you post the code that used array along with the .exists method?

[NeedForExcel]

@ skywriter - Perfect! Thank you for clarifying yet again..

@ jindon - Thank you for this very important input.. I'll remember that..

@ Kyle123 -

The biggest bottleneck is that you're looping through a range

So are you saying this isnt the best method? (Dont consider the Hard Coded range. I'v done that just for convenience while learning)

For Each R In Range("A2:A17")
      If R.Value <> "" Then .Item(R.Value) = Empty
Next R

you can use transpose but ymmv it tends to be slow

So which method if not transpose is best?

Thank you for the input guys.. You guys are awesome..

[Kyle123]

I'd do it like this, bear in mind most of these optimisations are not noticeable on small data sets:

Sub ScrpDict()

    Dim Dict As Scripting.Dictionary
    Dim R As Variant, keys As Variant
    Dim x As Long
    
    Set Dict = New Scripting.Dictionary
    
    R = Sheets(1).Range("A2:A101").Value2 'Value2 is faster than .Value
    
    With Dict
        For x = LBound(R) To UBound(R) 'Loop through Arrays by index
            If Len(R(x, 1)) > 0 And Not .Exists(R(x, 1)) Then 'Check whether the element exists
                .Add R(x, 1), Nothing 'Could also be empty
            End If
        Next x
    End With
    
    ReDim R(1 To Dict.Count, 1 To 1) 'Create an array to write to the sheet
    keys = Dict.keys() 'Get the keys
    
    For x = LBound(keys) To UBound(keys) 'Manual transpose to keys to a 2d array
        R(x + 1, 1) = keys(x)
    Next x
    
    Sheets(2).Range("A1").Resize(UBound(R), 1).Value2 = R 'Write the keys to a range
    
End Sub

[skywriter]

I'd do it like this, bear in mind most of these optimisations are not noticeable on small data sets

I have a sheet with a million rows, it ran very fast.

I ran it 3 times.
0.61, 0.62 and 0.61 seconds.

[Kyle123]

Did you change the range at the top?

[Kyle123]

No problem ,tanks for the rep

[skywriter]

Did you change the range at the top?

Here's the code wrapped by the timer code. I don't know how accurate this timer code is, but I consistently get 0.61 and 0.62 on a million rows of data. It's very fast.

Sub CalculateRunTime_Seconds()
'PURPOSE: Determine how many seconds it took for code to completely run
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim StartTime As Double
Dim SecondsElapsed As Double

'Remember time when macro starts
  StartTime = Timer
 Dim Dict As Scripting.Dictionary
    Dim R As Variant, keys As Variant
    Dim x As Long
    
    Set Dict = New Scripting.Dictionary
  
    R = Sheets(1).Range("A1:A1000000").Value2 'Value2 is faster than .Value
    
    With Dict
        For x = LBound(R) To UBound(R) 'Loop through Arrays by index
            If R(x, 1) <> "" And Not .Exists(R(x, 1)) Then 'Check whether the element exists
                .Add R(x, 1), Nothing 'Could also be empty
            End If
        Next x
    End With
    
    ReDim R(1 To Dict.Count, 1 To 1) 'Create an array to write to the sheet
    keys = Dict.keys() 'Get the keys
    
    For x = LBound(keys) To UBound(keys) 'Manual transpose to keys to a 2d array
        R(x + 1, 1) = keys(x)
    Next x
    
    Sheets(2).Range("A1").Resize(UBound(R), 1).Value2 = R 'Write the keys to a range


'Determine how many seconds code took to run
  SecondsElapsed = Round(Timer - StartTime, 2)

'Notify user in seconds
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

End Sub

[bakerman2]

For a little more accuracy I always use this for timing.

Private Declare Function getFrequency Lib "kernel32" _
Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare Function getTickCount Lib "kernel32" _
Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long

Function MicroTimer() As Double
' Returns seconds.
    Dim cyTicks1 As Currency
    Static cyFrequency As Currency
    MicroTimer = 0
' Get frequency.
    If cyFrequency = 0 Then getFrequency cyFrequency
' Get ticks.
    getTickCount cyTicks1
' Seconds
    If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency
End Function

Use like

Sub tst()
    dTime = MicroTimer
    For i = 1 To 10000
        DoEvents
    Next
    dTime = MicroTimer - dTime
    dTime = Round(dTime, 3)
    MsgBox CStr(dTime) & " Seconds", _
        vbOKOnly + vbInformation, "CalcTimer"
End Sub

where the For...Next replaces the code you want to execute.

'Source: http://msdn.microsoft.com/en-us/libr...ffice.12).aspx

[NeedForExcel]

@ skywriter, Kyle, Jindon & bakerman2 - Thank you all for the inputs..

I'll study the code given by Kyle & Skywriter.

Cheers Guys!

Marking the thread solved, and adding reps..

[NeedForExcel]

@Kyle - I ran your code on a million rows...

It is insanely fast..

[bakerman2]

Performing actions in memory is a technique I already use several years.
Run FillRange and then LoopMemory.
Run FillRange again and then run LoopCells. See the difference. I only took 500000 otherwise you have the time to get a cup of coffee when running LoopCells.

Private Declare Function getFrequency Lib "kernel32" _
Alias "QueryPerformanceFrequency" (cyFrequency As Currency) As Long
Private Declare Function getTickCount Lib "kernel32" _
Alias "QueryPerformanceCounter" (cyTickCount As Currency) As Long

Function MicroTimer() As Double
' Returns seconds.
    Dim cyTicks1 As Currency
    Static cyFrequency As Currency
    MicroTimer = 0
' Get frequency.
    If cyFrequency = 0 Then getFrequency cyFrequency
' Get ticks.
    getTickCount cyTicks1
' Seconds
    If cyFrequency Then MicroTimer = cyTicks1 / cyFrequency
End Function

Sub FillRange()
Dim sn(1 To 500000, 1 To 1)
For i = 1 To 500000
    sn(i, 1) = "AB"
Next
Range("A1").Resize(UBound(sn)) = sn

End Sub

Sub LoopMemory()
dTime = MicroTimer
sn = Sheets(1).Columns(1).SpecialCells(2)
    For i = 1 To UBound(sn)
        sn(i, 1) = sn(i, 1) & "C"
    Next
Range("A1").Resize(UBound(sn)) = sn
dTime = MicroTimer - dTime
dTime = Round(dTime, 3)
MsgBox CStr(dTime) & " Seconds", _
    vbOKOnly + vbInformation, "CalcTimer"
End Sub

Sub LoopCells()
dTime = MicroTimer
    For Each R In Sheets(1).Columns(1).SpecialCells(2)
            R.Value = R.Value & "C"
    Next R


dTime = MicroTimer - dTime
dTime = Round(dTime, 3)
MsgBox CStr(dTime) & " Seconds", _
    vbOKOnly + vbInformation, "CalcTimer"
End Sub