|
▼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
|
|