Извлечение значений ключей из scripting.dictionary в диапазон

Question

Я извлекаю значения ключей из g (объекта) в порядке, но они переписывают друг друга в диапазоне M, который я не понимаю, потому что он должен искать смещение? Мне явно чего-то не хватает. Есть идеи? Благодаря!

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 КОД:

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 

Answer 1

rngchassis.Value = и

Проблема заключается в том, что вы не приращение ячейки назначения и, следовательно, он держит перезапись:)

Untested - Это то, что вы пытаетесь?

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 

РЕДАКТИРОВАТЬ

Кстати, ваш выше код также может быть записана в виде (Примечание перезапуске диапазон)

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 

Answer 2

Цикл For Each u ... может быть заменен

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