CODEWITHSUNDEEP
excelvba
Mike
Mike

Reputation: 2751

Extracting keys values from scripting.dictionary into a range

I'm extracting the keys values from g (object) fine, but they are overwriting each other in the M range, which I don't understand because it should be looking for the offset? I'm clearly missing something. Any ideas? Thanks!

With wbkVer.Worksheets(1)
    Set g = CreateObject("scripting.dictionary")   
    Set rngChasssSrc = wbkCS.Worksheets(2).Range("Z3:Z20")
    Set rngchassis = wbkVer.Worksheets(1).Range("M" & .Rows.Count).End(xlUp).Offset(1, 0)
For Each k In rngChasssSrc
    tmp = Trim(Right(k.Value, 7))
    If Not IsEmpty(tmp) Then g(tmp) = g(tmp) + 1
Next k
For Each u In g.Keys()
    rngchassis.Value = u
Next u
End With

FINAL CODE:

With wbkVer.Worksheets(1)
    Set g = CreateObject("scripting.dictionary")
    Set rngChasssSrc = wbkCS.Worksheets(2).Range("Z3:Z20")
    Set rngchassis = .Range("M" & .Rows.Count).End(xlUp).Offset(1, 0)

    For Each k In rngChasssSrc
        If k > 0 then
        tmp = Trim(Right(k.Value, 7))
        If Not IsEmpty(tmp) Then g(tmp) = g(tmp) + 1
        End if
    Next k
    For Each u In g.Keys()
        rngchassis.Value = u
        Set rngchassis = .Range("M" & .Rows.Count).End(xlUp).Offset(1, 0)
    Next u
End With

Upvotes: 0

Views: 254

Answers (2)

chris neilsen
chris neilsen

Reputation: 53126

The For Each u ... loop can be replaced with

rngchassis.Resize(g.Count, 1) = Application.Transpose(g.Keys)

Upvotes: 0

Siddharth Rout
Siddharth Rout

Reputation: 149315

rngchassis.Value = u

The problem is that you are not incrementing the destination cell and hence it keeps overwriting it :)

Untested - Is this what you are trying? 

Option Explicit

Sub Sample()
    Dim lRow As Long

    With wbkVer.Worksheets(1)
        Set g = CreateObject("scripting.dictionary")
        Set rngChasssSrc = wbkCS.Worksheets(2).Range("Z3:Z20")

        '~~> Find Last Row in Col M for writing
        lRow = .Range("M" & .Rows.Count).End(xlUp).Row + 1

        For Each k In rngChasssSrc
            tmp = Trim(Right(k.Value, 7))
            If Not IsEmpty(tmp) Then g(tmp) = g(tmp) + 1
        Next k
        For Each u In g.Keys()
            .Range("M" & lRow).Value = u
            lRow = lRow + 1
        Next u
    End With
End Sub

EDIT

BTW, your above code can also be written as (Note resetting the range)

With wbkVer.Worksheets(1)
    Set g = CreateObject("scripting.dictionary")
    Set rngChasssSrc = wbkCS.Worksheets(2).Range("Z3:Z20")
    Set rngchassis = .Range("M" & .Rows.Count).End(xlUp).Offset(1, 0)

    For Each k In rngChasssSrc
        tmp = Trim(Right(k.Value, 7))
        If Not IsEmpty(tmp) Then g(tmp) = g(tmp) + 1
    Next k

    For Each u In g.Keys()
        rngchassis.Value = u
        Set rngchassis = .Range("M" & .Rows.Count).End(xlUp).Offset(1, 0)
    Next u
End With

Upvotes: 4

Related Questions