Copy Records to Worksheets based on value

[bconner]

I have a program below that will create a worksheet for each hospital in a report
What I would like to do next is copy and paste each Hospital record to the corresponding worksheet that was created....Can anyone help with this.....
Attached is an example report....




'Creates a worksheet for each Hospital
Dim rngstartP As Range
Dim rngendP As Range
Dim arySheets As Variant
Set rngendP = Range("F2:F" & Cells(Rows.Count, 8).End(xlUp).Row)


ReDim arySheets(1 To Worksheets.Count)
For ct = 1 To Worksheets.Count

arySheets(ct) = Worksheets(ct).Name
Next ct

For Each rngstartP In rngendP
If IsError(Application.Match(rngstartP.Value, arySheets, 0)) Then

Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = rngstartP.Offset(1, 0).Value
ReDim Preserve arySheets(1 To UBound(arySheets) + 1)
arySheets(UBound(arySheets)) = rngstartP.Offset(1, 0).Value
End If
Next rngstartP

[Bob Phillips]

Sub CreateSheets()
'Creates a worksheet for each Hospital
Dim rngFilter As Range
Dim rngstartP As Range
Dim rngendP As Range
Dim LastRow As Long
Dim ct As Long
Dim arySheets As Variant

Set rngendP = Range("F2:F" & Cells(Rows.Count, 8).End(xlUp).Row)

Application.DisplayAlerts = False
ReDim arySheets(1 To Worksheets.Count)
For ct = Worksheets.Count To 1 Step -1

If Not Worksheets(ct) Is ActiveSheet Then

arySheets(ct) = Worksheets(ct).Name
Worksheets(ct).Delete
End If
Next ct
Application.DisplayAlerts = True

LastRow = Cells(Rows.Count, "F").End(xlUp).Row

For Each rngstartP In rngendP

If IsError(Application.Match(rngstartP.Value, arySheets, 0)) Then

Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = rngstartP.Value
ReDim Preserve arySheets(1 To UBound(arySheets) + 1)
arySheets(UBound(arySheets)) = rngstartP.Value

Set rngFilter = rngstartP.Parent.Range("F1").Resize(LastRow)
rngFilter.AutoFilter field:=1, Criteria1:=rngstartP.Value
On Error Resume Next
Set rngFilter = rngFilter.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngFilter Is Nothing Then

rngFilter.EntireRow.Copy Worksheets(rngstartP.Value).Range("A1")
End If
End If
Next rngstartP

Worksheets(1).Activate
Worksheets(1).Range("F1").AutoFilter
End Sub

[bconner]

Worked!!! Thank you very much for your help I appreciate it......

Now comes the task of studying your code to figure out what each step is doing....