画像がぼやけてますけど、こんな感じでしょうかね？
Sub sample()
Dim myRng As Range
Dim trgName As String
Dim lstRow As Long, lstCol As Long
Dim i%, j%
With Sheet1
lstCol = .Cells(3, Columns.Count).End(xlToLeft).Column
j = (lstCol + 1) / 7
For i = 1 To j
trgName = Replace(.Cells(2, i * 7 - 1), "/", " ")
lstRow = Worksheets(trgName).Cells(Rows.Count, 1).End(xlUp).Row
Set myRng = .Cells(3, i * 7 - 1).CurrentRegion
If lstRow = 1 Then
myRng.Copy Destination:=Worksheets(trgName).Cells(1, 1)
Else
myRng.Offset(2).Resize(myRng.Rows.Count - 2).Copy _
Destination:=Worksheets(trgName).Cells(lstRow + 1, 1)
End If
Next i
End With
Set myRng = Nothing
MsgBox "完了"
End Sub
