質問: What & Expr End Sub
回答: Dictionaryオブジェクトを使った場合です。 変更と取消のルールが不明なので、最初に出て来た値です。 Sub sample() Dim dic As Object Dim lastRow As Long Dim r As Long Dim key1 As Variant Dim key2 As Variant Dim v As Variant ' Set dic = CreateObject("Scripting.Dictionary") 'Dictionaryオブジェクト lastRow = Range("A" & Rows.Count).End(xlUp).Row 'A列最終行 '集計 For r = 2 To lastRow '2行目から最終行まで key1 = Range("AJ" & r).Value '年月日(第1キー) key2 = Range("C" & r).Value '氏名(第2キー) If Not dic.exists(key1) Then dic.Add key1, CreateObject("Scripting.Dictionary") 'Dictionaryのキーにkey1が無ければ値をDictionaryで追加(第1階層) If Not dic(key1).exists(key2) Then 'dic(key1)のキーにkey2が無ければ dic(key1).Add key2, CreateObject("Scripting.Dictionary") 'dic(key1)のキーにkey2が無ければ値をDictionaryで追加(第2階層) dic(key1)(key2).Add "番号", CreateObject("Scripting.Dictionary") '"番号"をキーに値をDictionaryで追加 dic(key1)(key2).Add "分野", CreateObject("Scripting.Dictionary") '"分野"をキーに値をDictionaryで追加 dic(key1)(key2).Add "予定", CreateObject("Scripting.Dictionary") '"予定"をキーに値をDictionaryで追加 dic(key1)(key2).Add "変更", Range("BZ" & r).Value '"変更"をキーに値をBZ列の値で追加(最初の値) dic(key1)(key2).Add "取消", Range("CA" & r).Value '"取消"をキーに値をCA列の値で追加(最初の値) End If dic(key1)(key2)("番号")(dic(key1)(key2)("番号").Count) = Range("A" & r).Value '"番号"のキーの値を個数をキーに値をA列の値で設定(個数がキーなので追加) For Each v In Split(Range("B" & r).Value, "、") 'B列の値を"、"で区切って dic(key1)(key2)("分野")(v) = "" '"分野"に追加 Next For Each v In Split(Range("AS" & r).Value, "、") 'AS列の値を"、"で区切って dic(key1)(key2)("予定")(v) = "" '"予定"に追加 Next Next '結果表示 r = lastRow + 3 '表示行=最終行+3 Rows(1).Copy Rows(r) '見出しコピー r = r + 1 '表示行+1 For Each key1 In dic.Keys 'Dictionaryのキー(第1キー)を順に For Each key2 In dic(key1).Keys 'Dictionaryの第1キーのキー(第2キー)を順に Range("A" & r).Value = dic(key1)(key2)("番号")(0) & IIf(dic(key1)(key2)("番号").Count = 1, "", "等") '番号+2種類以上なら"等" Range("B" & r).Value = Join(dic(key1)(key2)("分野").Keys, "、") '"分野"のキーを"、"でつないで表示 Range("C" & r).Value = key2 '第2キー(氏名) Range("AJ" & r).Value = key1 '第1キー(年月日) Range("AS" & r).Value = Join(dic(key1)(key2)("予定").Keys, "、") '"予定"のキーを"、"でつないで表示 Range("BZ" & r).Value = dic(key1)(key2)("変更") '変更 Range("CA" & r).Value = dic(key1)(key2)("取消") '取消 r = r + 1 '表示行+1 Next Next End Sub