Excel VBA質問箱 IV

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

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


14688 / 76738 ←次へ | 前へ→

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

引用なし
パスワード
   ▼Yoshim さん:

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

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
0 hits

【67534】出現の名称をDictionaryで出す Yoshim 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で出す Yoshim 10/12/11(土) 11:52 お礼

14688 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free