Sub test()
'---------------------------------------------
11 Const タイトル行 = 1
12 Const 科目数 = 3
'---------------------------------------------
20 Dim endRow As Integer, writeRow As Integer, myCnt As Integer
21 Dim i As Integer, j As Integer, r As Integer
22 Dim myName As String
23 Dim myCHK As Boolean
24 Dim myArray
30 endRow = Cells(Rows.Count, 1).End(xlUp).Row
31 myArray = Range(Cells(1, 1), Cells(endRow, 科目数 + 2)).Value
32 Worksheets.Add
33 writeRow = 2
40 For i = タイトル行 To endRow
41 If i = タイトル行 Then
42 For r = 1 To 科目数 + 1
43 Cells(1, r).Value = myArray(タイトル行, r)
44 Next r
50 Else
51 If myArray(i, 科目数 + 2) <> "ck" Then
52 myCnt = 1
53 myName = myArray(i, 1)
54 For j = i + 1 To endRow
55 myCHK = True
60 For r = 2 To 科目数 + 1
61 If myArray(i, r) <> myArray(j, r) Then
62 myCHK = False
63 Exit For
64 End If
65 Next r
70 If myCHK = True Then
71 myName = myName & "・" & myArray(j, 1)
72 myArray(j, 科目数 + 2) = "ck"
73 myCnt = myCnt + 1
74 End If
75 Next j
80 If myCnt > 1 Then
81 Cells(writeRow, 1).Value = myName
82 For r = 2 To 科目数 + 1
83 Cells(writeRow, r).Value = myArray(i, r)
84 Next r
85 writeRow = writeRow + 1
86 End If
90 End If
91 End If
92 Next i
End Sub
ご教授お願い致します。
こんな感じ？