エクセルVBAでDictionaryオブジェクトについて

質問

エクセル2000です。
例えばA列に国名、B列に都市名、C列に団体名が切れ目なく並ぶリストがあります。
表はA列を基準にソートされています。

A列の同じ国名が終わる行のD列の1個のセルに、そこまでのC列で出てきた団体名を重複しないでカンマ区切りで表示しようと思います。
そのため、下記のようにDictionaryオブジェクトで団体名の重複を防いでいます。

Sub Test2()
Dim i As Long
Dim myStr As String
Dim myDic

Set myDic = CreateObject("Scripting.Dictionary")

For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
If myDic.exists(Cells(i, "C").Value) = False Then
myStr = myStr & Cells(i, "C").Value & "、"
myDic.Add Cells(i, "C").Value, ""
End If
If Cells(i, "A") <> Cells(i + 1, "A") Then
Cells(i, "D") = Left(myStr, Len(myStr) - 1)
myStr = ""
End If
Next i
End Sub

問題は、国をまたいで同じ団体名が出てきた場合、すでに上の方の国で変数myDicに登録されているため、登録されないということです。
上記コードでD列に変数myStを転記し、myStrを　= ""にした時に、変数myDicの方もクリアしてしまえばいいとは思うのですが、どうやってクリアしたらよいのかわかりません。
ご教示くださいませ。
こんな感じにしたいのです。

日本 東京 abc
日本 横浜 bbc
日本 大阪 bbc
日本 名古屋 abc
日本 札幌 abc bbc、abc
韓国 ソウル kbc
韓国 プサン kkc
韓国 テグ kbc
韓国 テジョン abc
韓国 インチョン bbc kbc、kkc、bbc、abc
北朝鮮 ピョンヤン xxc
北朝鮮 テポドン xxc xxc
中国 北京 ccc
中国 南京 ccc
中国 上海 abc
中国 大連 kbc ccc、abc、kbc

表が上手く表示されませんが、各国名の最終行のB列都市名の右の1個はC列の団体名で、その右にくっついて見えるのがD列のカンマ区切りのデータです。

回答No.7

Wendy02 · ベストアンサー

こんにちは。

# 4のお礼の部分ですが、
>これ正しいですか？

For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If myDic.Exists(Cells(i, "C").Value) = False Then
myDic.Add Cells(i, "C").Value, ""
End If
If Cells(i, "A") <> Cells(i + 1, "A") Then
n = myDic.Count　　　'←不要
ReDim myAr(n - 1)　　'←不要
myAr = myDic.keys　　'上で、Redim したmyAr のIndexは、壊れています。
Cells(i, "D") = Join(myAr, "、")
myDic.RemoveAll
End If
Next i
Set myDic = Nothing
End Sub

Dim myAr As Variant になっていますから、配列になったものを、Variant 型変数に渡せば、配列になります。

配列　　配列
myAr = myDic.keys

ですから、以下のように省略できます。

　For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
　　　　If myDic.Exists(Cells(i, "C").Value) = False Then
　　　　　　myDic.Add Cells(i, "C").Value, ""
　　　　End If
　　　　If Cells(i, "A") <> Cells(i + 1, "A") Then
　　　　　　Cells(i, "D") = Join(myDic.Keys, "、")　'既に配列になっています。
　　　　　　myDic.RemoveAll
　　　　End If
　Next i

お礼

> Dim myAr As Variant になっていますから、配列になったものを、Variant 型変数に渡せば、配列になります。

あ、そうなんですかぁ！
何から何までご指導いただき、まことにありがとうございました。

回答No.6

kobouzu_su

エキスパートさん、こんばんは。

新しい知識をちゃんと利用する態度、感心感心。。(^o^)。。
そしてまた、RemoveAllも覚えましたね。

さてさて、今回のはちょこっと視点を変えると、エキスパートさんのコードのままでもできます。

その方法は、キーを「団体名」のみにしないで、
国名を付加して、「国名＆団体名」をキーにしてやればいいのです。

'--------------------------------------------------　
Sub Test2()
　Dim i As Long
　Dim myStr As String
　Dim myDic

　Dim myKey　　　'●キー「国名＆団体名」用

　Set myDic = CreateObject("Scripting.Dictionary")

　For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row

　　　myKey = Cells(i, "A").Value & "@" & Cells(i, "C").Value　'●

　　　If myDic.exists(myKey) = False Then　　'●
　　　　　myStr = myStr & Cells(i, "C").Value & "、"
　　　　　myDic.Add myKey, ""　　'●
　　　End If

　　　If Cells(i, "A").Value <> Cells(i + 1, "A").Value Then
　　　　　Cells(i, "D").Value = Left(myStr, Len(myStr) - 1)
　　　　　myStr = ""
　　　End If

　Next i

End Sub
'--------------------------------------------------

●の部分が追加、変更箇所。

それから、
　　myKey = Cells(i, "A").Value & "@" & Cells(i, "C").Value
この　"@"　は、今回は不要ですが、場合によっては必要になることがあるので付けときました。

このようにちょこっと視点を変えてみると何かが見えてくるものです。(^o^)。。
以上です。

お礼

お大師様、いつも有難いお教えをいただき感謝いたしております。
九州地方の大雨は大丈夫だったのでしょうか？

流石ですね。
今回は新しいRemoveAllという呪文を使わせてもらいましたが、「国名＆団体名」をキーにするなんて思いつきませんでした。

有難うございました。

回答No.5

imogasi

#3です。VBSを使わずにやってみました。
余り行数は変わらないようです。
Sub Test4()
Dim i As Long
Dim s As String
Dim st
st = 1
s = ""
s = s & Cells(1, "c") & ","
m = Cells(1, "A")
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row + 1
If Cells(i, "A") = m Then
c = Application.WorksheetFunction.CountIf(Range(Cells(st, "C"), Cells(i, "C")), Cells(i, "c"))

If c > 1 Then
'2度目以後
Else
'１度目
s = s & Cells(i, "C") & ","
End If
Else
Cells(i - 1, "D") = Left(s, Len(s) - 1)
m = Cells(i, "A")
st = i
s = ""
s = s & Cells(i, "c") & ","
End If
Next i

End Sub
結果
D列

abc,bbc

kbc,kkc,abc,bbc

xxc

ccc,abc,kbc

お礼

ありがとうございます。
勉強になります。

回答No.4

Wendy02

こんにちは。Wendy02です。

本来は、Dictionary Object は、並べ替えしないままに使います。
ランダムに並んでいても、以下のようにはじきだしてくれます。

日本　　abc, bbc　　
韓国　　kbc, kkc, abc, bbc　　
北朝鮮　xxc
中国　　ccc, abc, kbc　　
なお、このDictionary Object も以下のInStr もBinary Compare モードになっていますので、実際は、大文字、小文字、全角、半角の区別をなくするためには、両方とも、TextCompare モードにしてあげます。

Sub Test3()
　　Dim i As Long
　　Dim j As Long
　　Dim myStr As String
　　Dim myDic As Object
　　Dim ar As Variant
　　Dim myKey As String
　　Dim myItem As String

　　Set myDic = CreateObject("Scripting.Dictionary")

　　For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row + 1
　　　　If myDic.Exists(Cells(i, "A").Value) = False Then
　　　　　　'ランダムに並んでいるときは、以下のIf 構文は使えない
　　　　　　If myDic.Count > 0 Then
　　　　　　　　ar = myDic.Items
　　　　　　　　Cells(i - 1, "D").Value = ar(j)
　　　　　　　　j = j + 1
　　　　　　End If
　　　　　　'---ここまで
　　　　　　myDic.Add Cells(i, "A").Value, Cells(i, "C").Value
　　　　Else
　　　　　　myKey = Cells(i, "A").Value
　　　　　　myItem = myDic.Item(myKey)
　　　　　　If InStr(myItem, Cells(i, "C").Value) = 0 Then
　　　　　　　　myDic.Item(myKey) = myDic.Item(myKey) & ", " & Cells(i, "C").Value
　　　　　　End If
　　　　End If
　　Next i
　　Cells(i + 1, "A").Resize(myDic.Count).Value = WorksheetFunction.Transpose(myDic.Keys)
　　Cells(i + 1, "C").Resize(myDic.Count).Value = WorksheetFunction.Transpose(myDic.Items)
End Sub

お礼

いつもご丁寧にありがとうございます。
よく考えてみたらなにも変数myStrに文字列を入れていかなくてもDictionaryのKeysを使えばいいんですよね？

Sub Test2()
Dim i As Long, n As Long
Dim myAr As Variant
Dim myDic As Object

Set myDic = CreateObject("Scripting.Dictionary")

For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If myDic.Exists(Cells(i, "C").Value) = False Then
myDic.Add Cells(i, "C").Value, ""
End If
If Cells(i, "A") <> Cells(i + 1, "A") Then
n = myDic.Count
ReDim myAr(n - 1)
myAr = myDic.keys
Cells(i, "D") = Join(myAr, "、")
myDic.RemoveAll
End If
Next i
Set myDic = Nothing
End Sub

これ正しいですか？

回答No.3

imogasi

#1のご回答を確認しました。
---
Sub Test2()
Dim i As Long
Dim myStr As String
Dim myDic
Dim myItem

Set myDic = CreateObject("Scripting.Dictionary")
d = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To d
If myDic.exists(Cells(i, "C").Value) = False Then
'存在しない
'文字列を連結累積
myStr = myStr & Cells(i, "C").Value & "、"
' Dicに追加
myDic.Add Cells(i, "C").Value, ""
End If
'--次行でA列の内容が変わるとき
If Cells(i, "A") <> Cells(i + 1, "A") Then
Cells(i, "D") = Left(myStr, Len(myStr) - 1)
myStr = ""
MsgBox myDic.Count
Set myDic = Nothing
Set myDic = CreateObject("Scripting.Dictionary")
End If
Next i
End Sub
ーー
結果
A列　　　B列　　　C列　　D列（国別集約）
日本 東京 abc
日本 横浜 bbc
日本 大阪 bbc
日本 名古屋 abc
日本 札幌 abc abc、bbc
韓国 ソウル kbc
韓国 プサン kkc
韓国 テグ kbc
韓国 テジョン abc
韓国 インチョン bbc kbc、kkc、abc、bbc
北朝鮮 ピョンヤン xxc
北朝鮮 テポドン xxc xxc
中国 北京 ccc
中国 南京 ccc
中国 上海 abc
中国 大連 kbc ccc、abc、kbc

ーー
これって、本来？の使い方でなく、重複のためにだけmyDicを使っているのですね。
後は各国でNothingにしているし、使えないですね。
ーー
質問標題は下記が適当かと。
VBScriptのDictionaryオブジェクト(のVBAでの利用）

お礼

有難うございます。＃１さんのと同じですね。

> これって、本来？の使い方でなく、重複のためにだけmyDicを使っているのですね。

本来の使い方を知らないといったほうが正しいです。
Dictionaryオブジェクトはまだ覚えたてで、重複チェックにしか使ったことがありません。
（*/∇＼*） キャ

回答No.2

Wendy02

こんにちは。

>上記コードでD列に変数myStを転記し、myStrを　= ""にした時に、変数myDicの方もクリアしてしまえばいいとは思うのですが、どうやってクリアしたらよいのかわかりません。

あまり、Dictionary Object は、あまり、めまぐるしく入れだしはしないのですが、

myStr = ""
の後に、
myDic.RemoveAll
と、RemoveAll メソッドを使用すればよいです。
単独で削除する場合は、もちろん、Remove メソッドです。

お礼

myDic.RemoveAll　ですか！
また新しい呪文を覚えました。
いつもいつも有難うございます。

回答No.1

pamsd

＞変数myDicの方もクリアしてしまえばいいとは思うのですが、どうやってクリアしたらよいのかわかりません。

Set myDic= Nothing

で 再度
Set myDic = CreateObject("Scripting.Dictionary")
をしないと ダメです。

お礼

myStr = ""
Set myDic = Nothing
Set myDic = CreateObject("Scripting.Dictionary")

で、クリアできました。
有難うございました。