Sub ProcessData()
Dim myDic As Object, myKey ' 辞書オブジェクトとキーを宣言
Dim c, myVal ' 変数cとmyValを宣言
Dim i As Long ' カウンタ変数iを宣言
Dim mySh As Worksheet ' ワークシートオブジェクトmyShを宣言
Dim myFlg As Boolean ' フラグ変数myFlgを宣言
Dim lastRow As Long, myRow As Long ' 最終行番号を格納する変数を宣言
Dim myK As String ' 文字列変数myKを宣言
'Scripting.Dictionaryオブジェクトを作成し、myDicに代入
Set myDic = CreateObject("Scripting.Dictionary")
'"Sheet5"ワークシートのA列の最終行番号をlastRowに格納
lastRow = Worksheets("Sheet5").Range("A" & Rows.Count).End(xlUp).Row
' "Sheet5"ワークシートのA2セルから最終行までの値をmyValに格納
myVal = Worksheets("Sheet5").Range("A2", "A" & lastRow).Value
' myVal内の各要素を処理するループ
For Each c In myVal
' セルが空ではない場合
If Not c = Empty Then
' 辞書オブジェクトにまだ追加されていない場合は追加
If Not myDic.Exists(c) Then
myDic.Add c, ""
End If
End If
Next
' 辞書オブジェクトのキーをmyKeyに格納
myKey = myDic.Keys
' myDicの要素数分ループ
For i = 0 To myDic.Count - 1
' 各ワークシートを処理するループ
For Each mySh In Worksheets
myFlg = False ' フラグを初期化
' 現在処理中のワークシートの名前がmyKey(i)と一致する場合
If mySh.Name = myKey(i) Then
myFlg = True ' フラグをTrueに設定
mySh.Cells.Delete ' ワークシートの内容を削除
Exit For ' ループを抜ける
End If
Next mySh
' フラグがFalseの場合（該当ワークシートが見つからない場合）
If myFlg = False Then
' 新しいワークシートを追加して、名前をmyKey(i)に設定
ActiveWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = myKey(i)
End If
' "Sheet5"ワークシートのA1:O1範囲を新しいワークシートにコピー
Worksheets("Sheet5").Range("A1:O1").Copy Worksheets(myKey(i)).Range("A1")
Next i
' 2行目から最終行までを処理するループ
For i = 2 To lastRow
' "Sheet5"ワークシートのB列の値をmyKに格納
myK = Worksheets("Sheet5").Range("A" & i).Value
' myKが空でない場合
If myK <> "" Then
' myKのワークシートのA列の最終行番号をmyRowに格納
myRow = Worksheets(myK).Range("A" & Rows.Count).End(xlUp).Row + 1
' "Sheet5"ワークシートのAからO列の値をmyKのワークシートの次の空行にコピー
Worksheets("Sheet5").Range("A" & i & ":O" & i).Copy _
Worksheets(myK).Range("A" & myRow & ":O" & myRow)
End If
Next i
Set myDic = Nothing ' 辞書オブジェクトを解放
End Sub
