Excel (VBA)

Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Home : Excel 2016)
Dictionary要素の加算
投稿日時: 19/10/07 19:45:05
投稿者: BILL20001001

     A     B     C    
1 担当1   担当3
2 100     200
3 担当1   担当2
4 300     500
5 担当2
6 300
 
    上記の表で担当者ごとに集計し、集計結果をMSGBOXで表示したいのですが、
  ご教示下さい。
             担当者1:400
             担当者2:800
             担当者3:200
  Dictionaryで集計してますが、同一担当者が加算されません。
  コーディングの不備箇所が判りません。[b][/b]

回答
投稿日時: 19/10/07 19:48:30
投稿者: 半平太

>コーディングの不備箇所が判りません。
 
どんなコードなのですか?

投稿日時: 19/10/07 22:28:24
投稿者: BILL20001001

半平太 さんの引用:
>コーディングの不備箇所が判りません。
 
どんなコードなのですか?

    Dim dic As Object
    Dim k As Long
    Dim j As Long
    Dim total As Long
    Dim var As Variant
    Dim hosei As String
    Dim str As String, i As Integer
    Dim Keys() As Variant
'
    Set dic = CreateObject("Scripting.Dictionary")
    For k = 1 To 5 Step 2
        For j = 1 To 2
            If Cells(k, j).Value <> "" Then
               If Not dic.exists(Cells(k, j).Value) Then
                  dic.Add Cells(k, j).Value, Cells(k + 1, j).Value
               Else
                  dic(Cells(k, j)) = dic(Cells(k, j)) + Cells(k + 1, j).Value
               End If
            End If
         Next
    Next
    Keys = dic.Keys
    For i = 0 To 27
        str = str & Keys(i) & " : " & dic.Item(Keys(i)) & vbCrLf
    Next i
    MsgBox str, vbInformation

回答
投稿日時: 19/10/07 23:11:24
投稿者: WinArrow
投稿者のウェブサイトに移動

 
横から失礼
修正版コード
 
Sub Test()
    Dim dic As Object
     Dim k As Long
     Dim j As Long
     Dim total As Long
     Dim var As Variant
     Dim hosei As String
     Dim str As String, i As Integer
     Dim Keys() As Variant
 '
     Set dic = CreateObject("Scripting.Dictionary")
     For k = 1 To 5 Step 2
         For j = 1 To 2
             If Cells(k, j).Value <> "" Then
                If Not dic.exists(Cells(k, j).Value) Then
                   dic.Add Cells(k, j).Value, Cells(k + 1, j).Value
                Else
                   dic.Item(Cells(k, j).Value) = dic.Item(Cells(k, j).Value) + Cells(k + 1, j).Value ’修正ヶ所(手抜きがあります)
                End If
             End If
          Next
     Next
     Keys = dic.Keys
     For i = 0 To dic.Count - 1  'カウンタ:27の根拠は?
         str = str & Keys(i) & " : " & dic.Item(Keys(i)) & vbCrLf
     Next i
     MsgBox str, vbInformation
End Sub

回答
投稿日時: 19/10/08 00:34:08
投稿者: simple

横から失礼します。補足です。
 
うまくいかない原因の大きなところは、

 dic(Cells(k, j)) = dic(Cells(k, j)) + Cells(k + 1, j).Value
です。
これは、
dic(Cells(k, j).Value) = dic(Cells(k, j).Value) + Cells(k + 1, j).Value
とは解釈してくれないのですね。
つまり、貴兄のコードでは、辞書のKeyはRangeオブジェクトそのものになっています。
そうではなくて、セルの値をキーにしないといけないのです。
 
 
以下、参考までに、私ならこう書くというのを示しておきます。
最初は、質問者さんのコードのような書き方を推奨します。
あくまで参考です。
Sub test()
    Dim dic As Object
    Dim k   As Long
    Dim j   As Long
    Dim str As String
    Dim key As Variant

    Set dic = CreateObject("Scripting.Dictionary")
    
    For k = 1 To 5 Step 2
        For j = 1 To 2
            If Cells(k, j).Value <> "" Then
                dic(Cells(k, j).Value) = dic(Cells(k, j).Value) + Cells(k + 1, j).Value
            End If
        Next
    Next

    For Each key In dic
        str = str & key & " : " & dic(key) & vbLf
    Next
    MsgBox str
End Sub

投稿日時: 19/10/08 07:31:31
投稿者: BILL20001001

WinArrow さんの引用:

横から失礼
修正版コード
 
Sub Test()
    Dim dic As Object
     Dim k As Long
     Dim j As Long
     Dim total As Long
     Dim var As Variant
     Dim hosei As String
     Dim str As String, i As Integer
     Dim Keys() As Variant
 '
     Set dic = CreateObject("Scripting.Dictionary")
     For k = 1 To 5 Step 2
         For j = 1 To 2
             If Cells(k, j).Value <> "" Then
                If Not dic.exists(Cells(k, j).Value) Then
                   dic.Add Cells(k, j).Value, Cells(k + 1, j).Value
                Else
                   dic.Item(Cells(k, j).Value) = dic.Item(Cells(k, j).Value) + Cells(k + 1, j).Value ’修正ヶ所(手抜きがあります)
                End If
             End If
          Next
     Next
     Keys = dic.Keys
     For i = 0 To dic.Count - 1  'カウンタ:27の根拠は?
         str = str & Keys(i) & " : " & dic.Item(Keys(i)) & vbCrLf
     Next i
     MsgBox str, vbInformation
End Sub
有難うございました。 'カウンタ:27の根拠は?:誤りです。すみません。