とりあえず下記のソースでご質問された内容の動作ができてる?ことを確認したので
試してみてください。
使うときの注意点として、
A列には日付、B列には名前を必ず入力することと、
一番左側のワークシート以外は全部削除してしまうので、
下記のプログラムを実行する前にSheet2やSheet3といったワークシートが
削除されてもいいか確認してください。
もし必要であればプログラムの解説もいたします。
Public Sub sub_SplitDate()
Dim i As Long, j As Long, k As Long
Dim lngBeforeDate As Long
Dim lngAfterDate As Long
Dim wbkActiveSheet As Worksheet
Dim rngInputData As Range
Dim r As Range
Dim lngLastRow As Long
Dim varInputArray As Variant
Set wbkActiveSheet = ActiveSheet
With Worksheets(1)
lngLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = 1 To lngLastRow
If i = lngLastRow Then Exit For
lngBeforeDate = DateValue(.Cells(i, 1).Value)
lngAfterDate = DateValue(.Cells(i + 1, 1).Value)
If lngBeforeDate = lngAfterDate Then
Else
j = j + 1
End If
Next i
j = j + 1
If Worksheets.Count > 1 Then
For i = 2 To Worksheets.Count
Application.DisplayAlerts = False
Worksheets(2).Delete
Application.DisplayAlerts = True
Next i
End If
For i = 1 To j
Worksheets.Add after:=Worksheets(Worksheets.Count)
Next i
wbkActiveSheet.Activate
j = 2
k = 1
For i = 1 To lngLastRow
If i = lngLastRow Then Exit For
' MsgBox Worksheets(1).Cells(i, 2).Value
lngBeforeDate = DateValue(.Cells(i, 1).Value)
lngAfterDate = DateValue(.Cells(i + 1, 1).Value)
If lngBeforeDate = lngAfterDate Then
With Worksheets(j)
If k = 1 And i = 1 Then
MsgBox Worksheets(1).Cells(i, 2).Value
.Cells(k, 1).Value = Worksheets(1).Cells(i, 1).Value
k = k + 1
.Cells(k, 1).Value = Worksheets(1).Cells(i, 2).Value
k = k + 1
Else
.Cells(k, 1).Value = Worksheets(1).Cells(i, 2).Value
k = k + 1
End If
End With
Else
Worksheets(j).Cells(k, 1).Value = Worksheets(1).Cells(i, 2).Value
j = j + 1
k = 1
Worksheets(j).Cells(k, 1).Value = Worksheets(1).Cells(i, 1).Value
k = k + 1
Worksheets(j).Cells(k, 1).Value = Worksheets(1).Cells(i, 2).Value
End If
Next i
Worksheets(j).Cells(k, 1).Value = Worksheets(1).Cells(lngLastRow, 2).Value
End With
End Sub