Excel VBA質問箱 IV

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

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


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

14684 / 76734

←次へ　｜　前へ→


	【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

1 hits

▼

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