Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

2538 / 13665 ﾂﾘｰ

←次へ　｜　前へ→

▼

【67534】出現の名称をDictionaryで出す Yoshiｍ 10/12/11(土) 8:53

【67535】Re:出現の名称をDictionaryで出す kanabun 10/12/11(土) 9:50

【67538】Re:出現の名称をDictionaryで出す kanabun 10/12/11(土) 10:44

【67540】Re:出現の名称をDictionaryで出す kanabun 10/12/11(土) 11:21

【67537】Re:出現の名称をDictionaryで出す 山猿 10/12/11(土) 10:20

【67539】Re:出現の名称をDictionaryで出す UO3 10/12/11(土) 11:07

【67542】Re:出現の名称をDictionaryで出す Yoshiｍ 10/12/11(土) 11:52


	【67534】出現の名称をDictionaryで出す

Yoshiｍ - 10/12/11(土) 8:53 -


	引用なし

	パスワード

Dictionaryで行き詰っています。よろしくお願いします。

B列に地域名（あ、さ、た、き、す）
C列に商品名（A、B、C型など）

商品名を基準に

商品出現回数＿商品名＿地域名
　　　２　　　　　A　　　あ、き、す
　　　３　　　　　C　　　さ　
　　　１　　　　　B　　　た

という表に仕上げたいのですが
地域名のところに出すやり方がわかりません、コードにアドバイス入れていただけませんでしょうか・・・

Sub test()
　　Dim myR As Range, Mycell As Range
　　Dim dic, key
　　Dim k As Long
　　Dim v　
Set myR = Range("C2" & ":" & "C" & Range("C" & Rows.Count).End(xlUp).Row)
　　Set dic = CreateObject("Scripting.Dictionary")　
　　For Each Mycell In myR
　　　　v = Mycell.Value
　　　　If v <> "" Then
　　　　　　dic(v) = dic(v) + 1
　　　　End If
　　Next　
　　k = 1
　　For Each key In dic.Keys
　　　　If dic(key) >= 1 Then
　　　　　　k = k + 1
　　　　　　Cells(k, "G").Value = dic(key)
　　　　　　Cells(k, "H").Value = key
　　　　End If
　　Next
End Sub


	【67535】Re:出現の名称をDictionaryで出す

kanabun - 10/12/11(土) 9:50 -


	引用なし

	パスワード

▼Yoshiｍさん：
>Dictionaryで行き詰っています。
>
>商品出現回数＿商品名＿地域名
>　　　２　　　　　A　　　あ、き、す
>　　　３　　　　　C　　　さ　
>　　　１　　　　　B　　　た
>
>という表に仕上げたいのですが
>地域名のところに出すやり方がわかりません、

コードには地域名を出力する部分がありませんね？
ご提示のコードをできるだけ活かすとすると、こんな追加で
行けるのでは？

　　Dictionaryに商品をキー登録するとき、対応するアイテムに
　　出力先の行番号を登録しておき、商品別に決められた（一意の）
　　行に出現回数のカウント、地域名の出力がされるように管理
　　させます。

Sub trial2()
　　Dim myR As Range, c As Range, r As Range
　　Dim dic As Object, key
　　Dim n As Long, k As Long
　　Dim v, sLocal As String
　　With Range("C:C")
　　　　Set myR = Excel.Range(.Item(2), .Item(.Count).End(xlUp))
　　End With
　　With Range("G1:I1")
　　　　.Resize(100).ClearContents
　　　　.Value = Array("商品出現回数", "商品名", "地域名")
　　　　Set r = .Offset(1)
　　End With
　　Set dic = CreateObject("Scripting.Dictionary")
　　For Each c In myR
　　　　v = c.Value
　　　　If Not IsEmpty(v) Then
　　　　　　If dic.Exists(v) Then
　　　　　　　　k = dic(v)　　'出力行番号を取得
　　　　　　Else
　　　　　　　　n = n + 1　　 '新規出力行番号
　　　　　　　　dic(v) = n　　'格納
　　　　　　　　k = n
　　　　　　　　r.Item(k, 2) = v
　　　　　　End If
　　　　　　r.Item(k, 1) = r.Item(k, 1).Value + 1 '出現回数
　　　　　　sLocal = r.Item(k, 3).Value　　　　　 '地域名
　　　　　　If Len(sLocal) Then sLocal = sLocal & ","
　　　　　　r.Item(k, 3) = sLocal & c(1, 0).Value
　　　　End If
　　Next
　　Set dic = Nothing
End Sub

これでとりあえず行けると思いますが、セルへ毎回出力しているので
画面がチラついて処理が重たくなっていると思います。
最終的には出力先範囲r と同じサイズの（十分な行数をもった）配列
を用意しておいて、処理は配列に対して行い、シートには最後に一回だけ
一括貼付けするようにすれば動作は軽く高速化できるとおもいます。


	【67537】Re:出現の名称をDictionaryで出す

山猿 - 10/12/11(土) 10:20 -


	引用なし

	パスワード

こんな書き方もあるかもしれないです。
Sub test()
　　Dim myR As Range, Mycell As Range
　　Dim dic, key
　　Dim k As Long
　　Dim v As String
　　Dim region As String

　　Set myR = Range("C2" & ":" & "C" & Range("C" & Rows.Count).End(xlUp).Row)
　　Set dic = CreateObject("Scripting.Dictionary")
　　For Each Mycell In myR
　　　　v = Mycell.Value
　　　　region = Mycell.Offset(, -1).Value
　　　　If v <> "" Then
　　　　　　If dic.Exists(v) Then
　　　　　　　　If InStr(dic(v), region) = 0 Then 'これは不要かも
　　　　　　　　　　dic(v) = dic(v) & region & ","
　　　　　　　　End If
　　　　　　Else
　　　　　　　　dic(v) = region & ","
　　　　　　End If
　　　　End If
　　Next
　　k = 1
　　For Each key In dic.Keys
　　　　k = k + 1
　　　　Cells(k, "G").Value = UBound(Split(dic(key), ","))
　　　　Cells(k, "H").Value = key
　　　　Cells(k, "I").Value = Left(dic(key), Len(dic(key)) - 1)
　　Next
　　Set dic = Nothing
End Sub


	【67538】Re:出現の名称をDictionaryで出す

kanabun - 10/12/11(土) 10:44 -


	引用なし

	パスワード

> 配列を用意しておいて､処理は配列に対して行い､
> シートには最後に一回だけ一括貼付けする
ように書き直すと、以下の感じになると思います。

Sub Trial3()　'配列利用
　　Dim myR As Range
　　Dim dic As Object
　　Dim i As Long, n As Long, k As Long
　　Dim v, sProdt As String, sLocal As String
　　With Range("C:C")
　　　　Set myR = Excel.Range(.Item(2), .Item(.Count).End(xlUp))
　　　　v = myR.Offset(, -1).Resize(, 2).Value2
　　End With
　　ReDim outv(myR.Count, 1 To 3)
　　outv(0, 1) = "商品出現回数"
　　outv(0, 2) = "商品名"
　　outv(0, 3) = "地域名"
　　Set dic = CreateObject("Scripting.Dictionary")
　　For i = 1 To UBound(v)
　　　　If Not IsEmpty(v(i, 2)) Then
　　　　　　sProdt = v(i, 2)
　　　　　　If dic.Exists(sProdt) Then
　　　　　　　　k = dic(sProdt)　　'出力行番号を取得
　　　　　　Else
　　　　　　　　n = n + 1　　　　　'新規出力行番号
　　　　　　　　dic(sProdt) = n　　'格納
　　　　　　　　k = n
　　　　　　　　outv(k, 2) = sProdt
　　　　　　End If
　　　　　　outv(k, 1) = outv(k, 1) + 1 '出現回数
　　　　　　sLocal = outv(k, 3)
　　　　　　If Len(sLocal) Then sLocal = sLocal & ","
　　　　　　outv(k, 3) = sLocal & v(i, 1)
　　　　End If
　　Next
　　Set dic = Nothing
　　With Range("G1").Resize(, 3)
　　　　.Resize(myR.Count).ClearContents
　　　　.Resize(n + 1).Value = outv
　　End With
End Sub

ただ山葵さんのコメントにあるように、

> If InStr(dic(v), region) = 0 Then 'これは不要かも

同じ商品名で地域名が重複して出てきたばあい
　　　↓

　　　地域名　　　商品名　
　　　あ　　　　　AA
　　　あ　　　　　AA
　　　あ　　　　　AA
　　　さ　　　　　AA

商品「AA」の出現回数は 4回で OK ですが、現状コードでは
地域名は「あ、あ、あ、さ」となってしまいます。

同じ商品で地域名はダブることはないのであればこのままでよい
のですが、重複して地域名が出現することがあるのであれば、どう
表示するのか、仕様を決めておかないといけないですね


	【67539】Re:出現の名称をDictionaryで出す

UO3 - 10/12/11(土) 11:07 -


	引用なし

	パスワード

▼Yoshiｍさん：

こんなコードでも。
同じ地域の手当てをしれて、あと、ループの中で文字列を連結するリスクを
回避しています。

Sub Sample()
　Dim wkV As Variant
　Dim myR As Range, Mycell As Range
　Dim dic As Object
　Dim dicS As Object
　Dim dicC As Object
　Dim key As Variant
　Dim v As String, a As String
　
　With Worksheets("Sheet1")　 '<== 元のシート　実際のシート名に
　　Set myR = .Range("C2:C" & .Range("C" & Rows.Count).End(xlUp).Row)
　End With
　
　Set dic = CreateObject("Scripting.Dictionary")
　Set dicS = CreateObject("Scripting.Dictionary")
　Set dicC = CreateObject("Scripting.Dictionary")
　
　For Each Mycell In myR
　　v = Mycell.Value
　　a = Mycell.Offset(0, -1).Value
　　If v <> "" Then
　　　If dicS.exists(v) Then
　　　　If Not dicC.exists(v & a) Then
　　　　　dicC(a) = True
　　　　　wkV = Split(dicS(v), ",")
　　　　　ReDim Preserve wkV(0 To UBound(wkV) + 1)
　　　　　wkV(UBound(wkV)) = a
　　　　　dicS(v) = Join(wkV, ",")
　　　　End If
　　　Else
　　　　dicS(v) = a
　　　End If
　　　dic(v) = dic(v) + 1
　　End If
　Next
　
　With Worksheets("Sheet2")　'<== 結果表示シート　実際のシート名に
　　Set myR = Intersect(.UsedRange, .UsedRange.Offset(1))
　　If Not myR Is Nothing Then myR.ClearContents
　　.Range("A2").Resize(dic.Count) = Application.Transpose(dic.items)
　　.Range("B2").Resize(dic.Count) = Application.Transpose(dic.keys)
　　.Range("C2").Resize(dic.Count) = Application.Transpose(dicS.items)
　End With
　
　Set dic = Nothing
　Set dicS = Nothing
　Set dicC = Nothing
　Set myR = Nothing
　
End Sub


	【67540】Re:出現の名称をDictionaryで出す

kanabun - 10/12/11(土) 11:21 -


	引用なし

	パスワード

同じ商品名で地域が重複していたばあい、重複カットして
表示するサンプルです。

Sub Trial3b()　'配列利用
　　Dim myR As Range
　　Dim dic As Object
　　Dim i As Long, n As Long, k As Long
　　Dim v, sProdt As String, sLocal As String, sL As String
　　With Range("C:C")
　　　　Set myR = Excel.Range(.Item(2), .Item(.Count).End(xlUp))
　　　　v = myR.Offset(, -1).Resize(, 2).Value2
　　End With
　　ReDim outv(myR.Count, 1 To 3)
　　outv(0, 1) = "商品出現回数"
　　outv(0, 2) = "商品名"
　　outv(0, 3) = "地域名"
　　Set dic = CreateObject("Scripting.Dictionary")
　　For i = 1 To UBound(v)
　　　　If Not IsEmpty(v(i, 2)) Then
　　　　　　sProdt = v(i, 2)
　　　　　　If dic.Exists(sProdt) Then
　　　　　　　　k = dic(sProdt)　　'出力行番号を取得
　　　　　　Else
　　　　　　　　n = n + 1　　 '新規出力行番号
　　　　　　　　dic(sProdt) = n　　'格納
　　　　　　　　k = n
　　　　　　　　outv(k, 2) = sProdt
　　　　　　End If
　　　　　　outv(k, 1) = outv(k, 1) + 1 '出現回数
　　　　　　sLocal = outv(k, 3)
　　　　　　If Len(sLocal) = 0 Then sLocal = " "
　　　　　　sL = " " & v(i, 1) & " "
　　　　　　If InStr(sLocal, sL) = 0 Then
　　　　　　　　outv(k, 3) = sLocal & sL
　　　　　　End If
　　　　End If
　　Next
　　Set dic = Nothing
　　With Range("G1").Resize(, 3)
　　　　.Resize(myR.Count).ClearContents
　　　　With .Resize(n + 1)
　　　　　　.Value = outv
　　　　　　With .Columns(3)
　　　　　　　　.Value = Application.Substitute( _
　　　　　　　　　　　Application.Trim(.Cells), " ", "、")
　　　　　　End With
　　　　End With
　　End With
End Sub


	【67542】Re:出現の名称をDictionaryで出す

Yoshiｍ - 10/12/11(土) 11:52 -


	引用なし

	パスワード

kanabunさん,山猿さん,UO3さん

新規投稿で書いてしまいました。失礼しました。

アドバイスありがとうございました。
またコードを書いていただきありがとうございます。

確かに地域名がダブって出てきます。
そこまで考えておりませんでした。

ただ回数のチェックとの関係で…。
地域名が今のところダブルのは仕方ないか？っと思っていますが、将来頻度が上がると・・・
地域の欄で　A（４）というような表現が出来ると良いと思いますが、コード的に今のところ付いていくのが・・・出来ないかと。もう少し勉強します。
ありがとうございました。
理解が進めば、また同じ内容で次のレベルの質問をさせていただきます。

ここまで書いていましたら、重複カットのコードがいただけたようで、びっくりしています。勉強してみます、ありがとうございました。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

2538 / 13665 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free