VBA 連想配列と回数

質問

Widowsは7
Excelは2013を使用しています。

E列のデータの重複しないリストをK列に書きだすところまでは出来たのですが、
同じ商品名が何回出てきたをカウントしたいのですが、
下記の連想配列で一緒に出来るのか、分けて組まないといけないのか、
教えて下さい。
よろしくお願い致します。
'----------------------------
'重複しないリストをK列に書き出す
'----------------------------

Dim Dic, i As Long, buf As String, Keys
Set Dic = CreateObject("Scripting.Dictionary")

For i = 2 To maxRow
buf = Cells(i, 5).Value 'E列のセルの値をbufに格納する
If Not Dic.Exists(buf) Then '辞書にまだ登録されていなければ
Dic.Add buf, buf 'そのセルの値を連想配列に登録する。
End If

Next i

'出力
Keys = Dic.Keys
For i = 0 To Dic.Count - 1
Cells(i + 2, 11) = Keys(i) 'K2から下にリスト作成
Next i
Set Dic = Nothing
End Sub

回答No.4

watabe007 · ベストアンサー

>E列からI列まで一括で出来ますか？
各列の最終行がE列と同じなら
Sub Test2()
　　Dim Dic As Object, c As Range
　　Set Dic = CreateObject("Scripting.Dictionary")
　　For Each c In Range("E2:I" & Cells(Rows.Count, "E").End(xlUp).Row)
　　　　Dic(c.Value) = Dic(c.Value) + 1
　　Next
　　'出力
　　Range("K2").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.Keys)
　　Range("L2").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.Items)
　　Set Dic = Nothing
End Sub
各列の最終行がＥ列と異なるのなら
Sub Test3()
　　Dim Dic As Object, i As Long, j As Long, buf As String
　　Set Dic = CreateObject("Scripting.Dictionary")
　　For i = 5 To 9 'E列からI列
　　　　For j = 2 To Cells(Rows.Count, i).End(xlUp).Row
　　　　　　buf = Cells(j, i).Value
　　　　　　Dic(buf) = Dic(buf) + 1
　　　　Next j
　　Next i
　　'出力
　　Range("K2").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.Keys)
　　Range("L2").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.Items)
　　Set Dic = Nothing
End Sub

お礼

watabe007様
E~Iまで書き出す事ができました！

私がE2→E最終行→F2→F最終行・・・・・という様に書き出したい事を、質問で説明していなかったでしで、少し思ったのと違う結果になってしまいました。
申し訳ありませんが、もう少し考えてみます。

ご回答いただきました事、感謝致します。
ありがとうございました。

補足

watabe007様
質問の返答を頂き、色々パターンを書いてくださって有り難く思います。
最終行が同じ方を組み込んでみたいです。
今は手元にないので、月曜日にやってみます。
お礼コメントは、その後に書かせていただきたいので、
少し時間を下さい。
本当にありがとうございました。

回答No.5

watabe007

>私がE2→E最終行→F2→F最終行・・・・・という様
？？？
E列の重複しないリストと重複数は、K、L列に
F列の重複しないリストと重複数は、M、N列に
・・・
なら
Sub Test4()
　　Dim Dic As Object, i As Long, j As Long, buf As String, k As Long
　　Set Dic = CreateObject("Scripting.Dictionary")
　　k = 11
　　For i = 5 To 9 'E列からI列
　　　　For j = 2 To Cells(Rows.Count, i).End(xlUp).Row
　　　　　　buf = Cells(j, i).Value
　　　　　　Dic(buf) = Dic(buf) + 1
　　　　Next j
　　　　'出力
　　　　Cells(2, k).Resize(Dic.Count, 1).Value = Application.Transpose(Dic.Keys)
　　　　Cells(2, k + 1).Resize(Dic.Count, 1).Value = Application.Transpose(Dic.Items)
　　　　k = k + 2
　　　　Dic.RemoveAll
　　Next i
　　Set Dic = Nothing
End Sub

お礼

watabe007様

ご回答いただきありがとうございます。
回数をカウントして出力するのはそのままですが、
すこし集計方法が変わりそうなので、このスレッドは解決とさせて頂きたく、お願い致します。

回答No.5の方もよく拝見して勉強させて頂きます。
（多分、別の案件につながると思います。）
色々ご教授頂き本当にありがとうございました。

回答No.3

watabe007

参考に
Sub Test()
　　Dim Dic As Object, c As Range
　　Set Dic = CreateObject("Scripting.Dictionary")
　　For Each c In Range("E2", Cells(Rows.Count, "E").End(xlUp))
　　　　Dic(c.Value) = Dic(c.Value) + 1
　　Next
　　'出力
　　Range("K2").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.Keys)
　　Range("L2").Resize(Dic.Count, 1).Value = Application.Transpose(Dic.Items)
　　Set Dic = Nothing
End Sub

お礼

watabe007様
ありがとうございます。
書いてくださったのを活用させていただくと、
E列からI列まで一括で出来ますか？

回答No.2

f272

#1です。
ごめんなさい。
Dic.Add buf, buf 'そのセルの値を連想配列に登録する。
は
Dic.Add buf, 1 'そのセルの値を連想配列に登録する。
に書き換えるというのが，抜けていました。

お礼

f272様
出来ました！
大変ありがとうございました。
1日悩んでいたことから、次に進むことが出来ます。
感謝です。

もしお時間がありましたら、
Dic.Add buf, buf 　と　Dic.Add buf, 1　の違いを教えて頂けないでしょうか？

同じ商品名が出てきたら、+1づつカウントしていく、と思って良いのでしょうか？

補足

Dic.Add buf, buf 　と　Dic.Add buf, 1　の違い、
分かりました。
私の思い違いで理解出来てなかった事が、
回答頂いたのをきっかけに理解する事ができました。
ありがとうございました。

回答No.1

f272

Dic.Add buf, buf 'そのセルの値を連想配列に登録する。
の下に
Else
Dic(buf) = Dic(buf) + 1
を追加して，書き出しの
Cells(i + 2, 11) = Keys(i) 'K2から下にリスト作成
の下に
Cells(i + 2, 12) = Dic(Keys(i))
を追加すればどうかな？

補足

f272様
ご回答いただきありがとうございます。
Dic(buf) = Dic(buf) + 1　のことろで、
エラーコード　13　の　型が一致しませんになってしまいました。