Try this
Sub FanOut()
Dim ColHead As String
Dim ColHeadCell As Range
Dim iCol As Integer
Dim iRow As Long 'row index on Fan Data sheet
Dim lRow As Integer 'row index on individual destination sheet
Dim NewWB As Workbook
Dim Dsheet As Worksheet 'destination worksheet
Dim Fsheet As Worksheet 'fan data worksheet (assumed active)

Again:
ColHead = InputBox("Enter Column Heading", "Identify Column", [H1].Value)
If ColHead = "" Then Exit Sub
Set ColHeadCell = Rows(1).Find(ColHead, lookat:=xlWhole)
If ColHeadCell Is Nothing Then
MsgBox "Heading not found in row 1"
GoTo Again
End If

Set Fsheet = ActiveSheet
Set NewWB = Workbooks.Add

iCol = ColHeadCell.Column
'loop through values in selected column
For iRow = 2 To Fsheet.Cells(65536, iCol).End(xlUp).Row
If Not SheetExists(CStr(Fsheet.Cells(iRow, iCol).Value)) Then
Set Dsheet =
NewWB.Worksheets.Add(after:=NewWB.Worksheets(NewWB .Worksheets.Count))
Dsheet.Name = CStr(Fsheet.Cells(iRow, iCol).Value)
Else
Set Dsheet = Worksheets(CStr(Fsheet.Cells(iRow, iCol).Value))
End If
lRow = Dsheet.Cells(65536, iCol).End(xlUp).Row
Fsheet.Rows(iRow).Copy Destination:=Dsheet.Rows(lRow + 1)
Next iRow

End Sub

Function SheetExists(SheetId As Variant) As Boolean

' This function checks whether a sheet (can be a worksheet,
' chart sheet, dialog sheet, etc.) exists, and returns
' True if it exists, False otherwise. SheetId can be either
' a sheet name string or an integer number. For example:

' If SheetExists(3) Then Sheets(3).Delete

' deletes the third worksheet in the workbook, if it exists.
' Similarly,

' If SheetExists("Annual Budget") Then Sheets("Annual Budget").Delete

' deletes the sheet named "Annual Budget", if it exists.

Dim Sh As Object
On Error GoTo NoSuch
Set Sh = Sheets(SheetId)
SheetExists = True
Exit Function
NoSuch:
If Err = 9 Then SheetExists = False Else Stop

End Function


"JC" wrote:

Hi..

I have 1 workbook with data pertaining to different managers.. Want to
make different worksheets for different planners.. Please help..

Thanks
JC