0

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

最終コード：

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
4

2 に答える 2

4

rngchassis.Value = u

問題は、宛先セルをインクリメントしていないため、上書きし続けることです:)

未テスト- これはあなたがしようとしていることですか?

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
于 2013-02-19T20:33:42.620 に答える
0

ループは次のFor Each u ...ものに置き換えることができます

rngchassis.Resize(g.Count, 1) = Application.Transpose(g.Keys)
于 2013-02-20T11:15:51.903 に答える