Sub 結合()
Dim ws As Worksheet
Dim lastRow As Long
Dim dict As Object
Dim key As String
Dim i As Long
Dim result As String
' 新しいディクショナリを作成
Set dict = CreateObject("Scripting.Dictionary")
' データがあるシートを指定
Set ws = ThisWorkbook.Sheets("Sheet1")
' 最終行を取得
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' データをディクショナリに追加
For i = 2 To lastRow ' ヘッダー行を無視するため2からスタート
key = ws.Cells(i, 1).Value & ":" & ws.Cells(i, 2).Value ' キーを作成
If Not dict.exists(key) Then
' キーが存在しない場合は新しく追加
dict.Add key, ws.Cells(i, 3).Value & ":" & ws.Cells(i, 4).Value
Else
' キーが存在する場合は既存の値に追加
dict(key) = dict(key) & vbCrLf & ws.Cells(i, 3).Value & ":" & ws.Cells(i, 4).Value
End If
Next i
' 結果を書き出す
For i = 2 To lastRow
key = ws.Cells(i, 1).Value & ":" & ws.Cells(i, 2).Value ' キーを作成
If dict.exists(key) Then
ws.Cells(i, 6).Value = dict(key)
End If
Next i
End Sub
Sub 結合2()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim lastRow As Long
Dim dict As Object
Dim key As Variant
Dim i As Long
Dim result As String
' 新しいディクショナリを作成
Set dict = CreateObject("Scripting.Dictionary")
' データがあるシートを指定
Set ws1 = ThisWorkbook.Sheets("Sheet1")
Set ws2 = ThisWorkbook.Sheets("Sheet2")
' 最終行を取得
lastRow = ws1.Cells(ws1.Rows.Count, "A").End(xlUp).Row
' データをディクショナリに追加
For i = 2 To lastRow ' ヘッダー行を無視するため2からスタート
key = ws1.Cells(i, 1).Value & "/" & ws1.Cells(i, 2).Value ' キーを作成
If Not dict.exists(key) Then
' キーが存在しない場合は新しく追加
dict.Add key, ws1.Cells(i, 3).Value & ":" & ws1.Cells(i, 4).Value
Else
' キーが存在する場合は値を更新
dict(key) = dict(key) & vbCrLf & ws1.Cells(i, 3).Value & ":" & ws1.Cells(i, 4).Value
End If
Next i
' 結果を書き出す
i = 2
For Each key In dict.keys
'ws2.Cells(i, 1).Value = Split(key, ":")(0) ' キーの1つ目の要素（Sheet1のA列）を書き込み
'ws2.Cells(i, 2).Value = Split(key, ":")(1) ' キーの2つ目の要素（Sheet1のB列）を書き込み
ws2.Cells(i, 1).Value = key
ws2.Cells(i, 3).Value = dict(key) ' 対応する値を書き込み
i = i + 1
Next key
End Sub
