|
▼Akari さん:
処理速度はhirofumiさんのものと比べ、自信はありませんが
こんなやりかたもあるかもしれません。
Option Explicit
Sub Sample()
Dim myDic As Object
Dim sepChr As String
Dim myKey
Dim myLines As Long
Dim aaa
Dim i As Long
Set myDic = CreateObject("Scripting.Dictionary")
Worksheets("Sheet2").Range("A1:D1").Value = Worksheets("Sheet1").Range("A1:D1").Value
Worksheets("Sheet2").Range("E1") = "受注先グループ"
With Worksheets("Sheet1")
myLines = .UsedRange.Rows.Count
For i = 2 To myLines
myKey = .Range("A" & i) & Chr(13) & _
.Range("B" & i) & Chr(13) & _
.Range("C" & i) & Chr(13) & _
.Range("D" & i)
sepChr = ""
If myDic(myKey) <> "" Then sepChr = "、"
myDic(myKey) = myDic(myKey) & sepChr & .Range("E" & i)
Next
End With
i = 2
With Worksheets("Sheet2")
For Each myKey In myDic
aaa = Split(myKey, Chr(13))
.Range("A" & i).Resize(, 4) = aaa
.Range("E" & i) = myDic(myKey)
i = i + 1
Next
End With
Set myDic = Nothing
End Sub
|
|