Separate Excel rows into individual sheets and retain header - vba

Question

I am trying to use VBA in Excel to separate rows into separate sheets and retain headers. Below is what I have so far. It works except I get the header row, then the individual row I want to move to the sheet is there BUT it's there three times instead of one. I am basically going by trial and error and I am stumped. Help please! I have no experience with this:
Sub DispatchTimeSeriesToSheets()
Dim ws As Worksheet
Set ws = Sheets("Scoring")
Dim LastRow As Long
LastRow = Range("A" & ws.Rows.Count).End(xlUp).Row
' stop processing if we don't have any data
If LastRow < 2 Then Exit Sub
Application.ScreenUpdating = False
SortScoring LastRow, ws
CopyDataToSheets LastRow, ws
ws.Select
Application.ScreenUpdating = True
End Sub
Sub SortScoring(LastRow As Long, ws As Worksheet)
ws.Range("A4:W" & LastRow).Sort Key1:=ws.Range("A4"), Key2:=ws.Range("W4")
End Sub
Sub CopyDataToSheets(LastRow As Long, src As Worksheet)
Dim rng As Range
Dim cell As Range
Dim Series As String
Dim SeriesStart As Long
Dim SeriesLast As Long
Set rng = Range("A4:A" & LastRow)
SeriesStart = 2
Series = Range("A" & SeriesStart).Value
For Each cell In rng
If cell.Value <> Series Then
SeriesLast = cell.Row - 1
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
Series = cell.Value
SeriesStart = cell.Row
End If
Next
' copy the last series
SeriesLast = LastRow
CopySeriesToNewSheet src, SeriesStart, SeriesLast, Series
End Sub
Sub CopySeriesToNewSheet(src As Worksheet, Start As Long, Last As Long, _
name As String)
Dim tgt As Worksheet
If (SheetExists(name)) Then
MsgBox "Sheet " & name & " already exists. " _
& "Please delete or move existing sheets before" _
& " copying data from the Scoring.", vbCritical, _
"Time Series Parser"
End
End If
Worksheets.Add(After:=Worksheets(Worksheets.Count)).name = name
Set tgt = Sheets(name)
' copy header row from src to tgt
tgt.Range("A1:W1").Value = src.Range("A1:W1").Value
' copy data from src to tgt
tgt.Range("A4:W" & Last - Start + 2).Value = _
src.Range("A" & Start & ":W" & Last).Value
End Sub
Function SheetExists(name As String) As Boolean
Dim ws As Worksheet
SheetExists = True
On Error Resume Next
Set ws = Sheets(name)
If ws Is Nothing Then
SheetExists = False
End If
End Function

Answer 1

Try this:
Sub doitall()
Dim ows As Worksheet
Dim tws As Worksheet
Dim rng As Range
Dim cel As Range
Dim LastRow As Long
Dim tLastRow As Long
Set ows = Sheets("Scoring")
With ows
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A4:A" & LastRow)
For Each cel In rng
If Not SheetExists(cel.Value) Then
Set tws = Worksheets.Add(After:=Sheets(Worksheets.Count))
tws.Name = cel.Value
tws.Rows(1).Resize(3).Value = .Rows(1).Resize(3).Value
Else
Set tws = Sheets(cel.Value)
End If
tLastRow = tws.Range("A" & tws.Rows.Count).End(xlUp).Offset(1).Row
tws.Rows(tLastRow).Value = .Rows(cel.Row).Value
Next
End With
End Sub
Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
On Error Resume Next
If WB Is Nothing Then Set WB = ActiveWorkbook
SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function

Answer 2

This will do what you are looking for
Const HeaderRow = 3
Sub MoveRecordsByValues()
Dim ws As Worksheet
Dim dws As Worksheet
Dim SheetName As String
Application.DisplayAlerts = False
For Each ws In Sheets
If ws.name <> "Scoring" Then ws.Delete
Next ws
Set ws = Sheets("Scoring")
StartRow = HeaderRow + 1
LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
For RowCounter = StartRow To LastRow
SheetName = ws.Cells(RowCounter, 1)
If Not SheetExists(SheetName) Then SetUpSheet SheetName, ws, HeaderRow
Set dws = Worksheets(SheetName)
DestLastRow = dws.Range("A" & dws.Rows.Count).End(xlUp).Row + 1
ws.Rows(RowCounter).Copy dws.Cells(DestLastRow, 1)
Next RowCounter
Application.DisplayAlerts = True
End Sub
Function SheetExists(name As String) As Boolean
SheetExists = True
On Error GoTo errorhandler
Sheets(name).Activate
Exit Function
errorhandler:
SheetExists = False
End Function
Sub SetUpSheet(name, SourceSheet, HeaderRow)
Dim DestSheet As Worksheet
Set DestSheet = Sheets.Add
DestSheet.name = name
SourceSheet.Rows(1).Copy DestSheet.Cells(1, 1)
SourceSheet.Rows(2).Copy DestSheet.Cells(2, 1)
SourceSheet.Rows(3).Copy DestSheet.Cells(3, 1)
End Sub