VBAスクリプト辞書、キーごとの複数のアイテム、アイテムの合計/カウント

Question

キーごとに複数のアイテムを含む辞書を作成したいと考えています。以下は私が今作業しているコードです。私は辞書を使って遊ぶのに7時間以上を費やしました。私はそれを理解できないようです。私の辞書のキーとして、私の範囲の入力からユニークな値を取得する問題はありません、問題は各キーに項目を追加するときに来る。キーが既に存在する場合は、そのキーのアイテムにSUMを追加（または追加）したり、そのキーの別のアイテムに格納されるそのキーの「カウント」を増やしたいとします。おそらく、それはビジュアルを通じて説明されるのがベストでしょう。

Key  Item1  Item2 
PersonA 20   SomeOtherVal 
PersonB 40   SomeOtherVal 
PersonA 80   SomeOtherVal 
PersonB 17   SomeOtherVal 
PersonC 13   SomeOtherVal 

Result: 
Key  Item1(Sum) Item2(Count) 
PersonA 100  2 
PersonB 57   2 
PersonC 13   1 

ご覧のとおり、存在するすべてのユニークなアイテムは、独自のキーとして作成されます。キーがすでに存在する場合は、Item1がキーの現在の合計に追加され、アイテム2にはカウントがあり、その値は1ずつ増加します。以下は使用しているコードです。私はめったに遭遇しない区切り文字で単一.Itemに複数の値を接合する方法を使用し

Sub dictionaryCreate() 

Dim Pair As Variant 
Dim q As Range 
Dim RAWDATA As Range 

Dim d As Dictionary        'Object 
Set d = New Dictionary       'CreateObject("Scripting.Dictionary") 

Set RAWDATA = Worksheets("RAW_DATA").Range(Cells(2, 1), Cells(3000, 1)) 
For Each q In RAWDATA 
    Pair = q.Offset(0, 60).Value + q.Offset(0, 65).Value 
    If d.Exists(Pair) Then 
     'ADD to item1 SUM 
     'Add to item2 COUNT 
    Else 
     d(Pair) = 1 'create new key 
    End If 
Next 

End Sub 

Answer 1

クラスオブジェクトはこのタスクには理想的です。あなた自身のデータフィールドを作成するために、別の機能を追加することもできます（例えば、個々のアイテムを保存するか、合計とカウントを平均化する関数を持つことができます）。加えて）。

Collectionオブジェクトでプリミティブデータ型を修正できないため、後者は非常に便利です。たとえば、dの項目がIntegerの場合、コードd(key) = d(key) + 1には入りませんでした。 d(key)の値を一時変数に読み込み、1ずつ増やして古い値を削除してから新しい一時変数を追加する必要があります（Collectionの順序が重要な場合は、さらに厳しいタスクがあります） ）。ただし、これらのタイプのオブジェクトは参照によって保存されるため、オブジェクトのプロパティを心臓のコンテンツに合わせて修正することができます。

私はCollectionをDictionaryより多く参照しています。これは、お客様の要件がCollectionに適していると考えているためです。a）生データが（おそらく3000個を超える）かなり大きい可能性があります。ライブラリRuntimeを参照するという面倒があります。

以下は、それがどのように動作するかを示す2つの追加機能を備えたクラスオブジェクトの例です。

Public Key As String 
Public Sum As Long 
Public Count As Long 
Public ItemList As Collection 
Public Function Mean() As Double 
    Mean = Sum/Count 
End Function 
Private Sub Class_Initialize() 
    Sum = 0 
    Count = 0 
    Set ItemList = New Collection 
End Sub 

あなたはその後、としてあなたのメインモジュールであなたのコレクションに項目を追加します。あなたは私が名前プロパティウィンドウで、このクラスcItems呼ばれてきました〜>クラスモジュールを挿入してお使いのエディタで作成します次の：

Dim col As Collection 
Dim dataItems As cItems 
Dim itemKey As String 
Dim item1 As Long 
Dim ws As Worksheet 
Dim r As Long 

Set ws = ThisWorkbook.Worksheets("RAW_DATA") 
Set col = New Collection 

For r = 2 To 3000 
    itemKey = CStr(ws.Cells(r, "A").Value2) '~~adjust to your own column(s) 
    item1 = CLng(ws.Cells(r, "B").Value2) '~~adjust to your own column(s) 

    'Check if key already exists 
    Set dataItems = Nothing: On Error Resume Next 
    Set dataItems = col(itemKey): On Error GoTo 0 

    'If key doesn't exist, create a new class object 
    If dataItems Is Nothing Then 
     Set dataItems = New cItems 
     dataItems.Key = itemKey 
     col.Add dataItems, itemKey 
    End If 

    'Add cell values to the class object 
    With dataItems 
     .Sum = .Sum + item1 
     .Count = .Count + 1 
     .ItemList.Add item1 
    End With 

Next 

あなたがアイテムのいずれかまたは全てにアクセスしたい場合は、そのようにそれを行うだろう：

'Iterating through all of the items 
For Each dataItems In col 
    Debug.Print dataItems.Mean 
Next 

'Selecting one item 
Set dataItems = col("PersonA") 
Debug.Print dataItems.Mean 

Answer 2

。 .Itemは、辞書が構築されるときに分割され、要素が調整されます。 VBEのイミディエイトウィンドウから

Sub dictionaryCreate() 

    Dim rw As Long, vITM As Variant, vKEY As Variant 
    Dim d As New Dictionary ' or Object & CreateObject("Scripting.Dictionary") 

    d.CompareMode = vbTextCompare 

    With Worksheets("RAW_DATA") 
     For rw = 2 To 3000 'maybe this ~> .Cells(Rows.Count, 1).End(xlUp).Row 
      If d.Exists(.Cells(rw, 1).Value2) Then 
       vITM = Split(d.Item(.Cells(rw, 1).Value2), ChrW(8203)) 
       d.Item(.Cells(rw, 1).Value2) = _ 
        Join(Array(vITM(0) + .Cells(rw, 2).Value2, vITM(1) + 1), ChrW(8203)) 'modify and join on a zero-width space 
      Else 
       d.Add Key:=.Cells(rw, 1).Value2, _ 
         Item:=Join(Array(.Cells(rw, 2).Value2, 1), ChrW(8203)) 'join on a zero-width space 
      End If 
     Next rw 
    End With 

    Debug.Print "key" & Chr(9) & "sum" & Chr(9) & "count" 
    For Each vKEY In d.Keys 
     Debug.Print vKEY & Chr(9) & _ 
        Split(d.Item(vKEY), ChrW(8203))(0) & Chr(9) & _ 
        Split(d.Item(vKEY), ChrW(8203))(1) 
    Next vKEY 

    d.RemoveAll: Set d = Nothing 

End Sub 

結果：

あなたのサンプルデータを使用して

key  sum count 
PersonA 100 2 
PersonB 57 2 
PersonC 13 1 

Answer 3

とクラス

clsItem：

Public Sum As Double 
Public Count As Long 

モジュール：

Sub dictionaryCreate() 

    Dim Pair As Variant 
    Dim q As Range, v, k 
    Dim RAWDATA As Range 

    Dim d As Dictionary 
    Set d = New Dictionary 

    Set RAWDATA = [A2:A6] 
    For Each q In RAWDATA 
     Pair = q.Value 
     v = q.Offset(0, 1).Value 'get the value to be added... 
     If d.Exists(Pair) Then 
      d(Pair).Sum = d(Pair).Sum + v 
      d(Pair).Count = d(Pair).Count + 1 
     Else 
      d.Add Pair, NewItem(v) 
     End If 
    Next 

    'print out dictionary content 
    For Each k In d 
     Debug.Print k, d(k).Sum, d(k).Count 
    Next k 
End Sub 

Function NewItem(v) As clsItem 
    Dim rv As New clsItem 
    rv.Sum = v 
    rv.Count = 1 
    Set NewItem = rv 
End Function 

Answer 4

溶液は、@ジープと同様ですが、若干の違いがあります。

Sub test() 
    Dim i, cl As Range, Dic As Object 
    Set Dic = CreateObject("Scripting.Dictionary") 
    Dic.CompareMode = vbTextCompare 
    For Each cl In Sheets("RAW_DATA").[A2:A6] 
     If Not Dic.Exists(cl.Value) Then 
      Dic.Add cl.Value, cl.Offset(, 1).Value2 & "|" & 1 
     Else 
      Dic(cl.Value) = Split(Dic(cl.Value), "|")(0) + cl.Offset(, 1).Value2 & _ 
         "|" & Split(Dic(cl.Value), "|")(1) + 1 
     End If 
    Next cl 
    Debug.Print "Key", "Sum", "Count" 
    For Each i In Dic 
     Debug.Print i, Split(Dic(i), "|")(0), Split(Dic(i), "|")(1) 
    Next i 
End Sub 

---

テスト