エクセル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
日本札幌abcbbc、abc
韓国ソウルkbc
韓国プサンkkc
韓国テグkbc
韓国テジョンabc
韓国インチョンbbckbc、kkc、bbc、abc
北朝鮮ピョンヤンxxc
北朝鮮テポドンxxcxxc
中国北京ccc
中国南京ccc
中国上海abc
中国大連kbcccc、abc、kbc

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

No.7 ベストアンサー 回答者： Wendy02 回答日時： 2007/07/20 15:18

こんにちは。

# 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 型変数に渡せば、配列になります。

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

お礼日時：2007/07/20 16:51

No.6 回答者： kobouzu_su 回答日時： 2007/07/19 23:25

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

新しい知識をちゃんと利用する態度、感心感心。。(^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という呪文を使わせてもらいましたが、「国名＆団体名」をキーにするなんて思いつきませんでした。

有難うございました。

お礼日時：2007/07/20 13:48

No.5 回答者： imogasi 回答日時： 2007/07/19 21:30

#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

この回答へのお礼

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

お礼日時：2007/07/20 13:40

No.4 回答者： Wendy02 回答日時： 2007/07/19 17:38

こんにちは。

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

これ正しいですか？

お礼日時：2007/07/20 13:37

No.3 回答者： imogasi 回答日時： 2007/07/19 16:28

#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
日本札幌abcabc、bbc
韓国ソウルkbc
韓国プサンkkc
韓国テグkbc
韓国テジョンabc
韓国インチョンbbckbc、kkc、abc、bbc
北朝鮮ピョンヤンxxc
北朝鮮テポドンxxcxxc
中国北京ccc
中国南京ccc
中国上海abc
中国大連kbcccc、abc、kbc

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

この回答へのお礼

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

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

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

お礼日時：2007/07/19 16:40

No.2 回答者： Wendy02 回答日時： 2007/07/19 16:12

こんにちは。

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

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

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

この回答へのお礼

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

お礼日時：2007/07/19 16:37

No.1 回答者： pamsd 回答日時： 2007/07/19 15:20

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

Set myDic= Nothing

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

この回答へのお礼

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

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

お礼日時：2007/07/19 16:36