Macro To Keep Column Headers

[lkohlri]

Currently, I am running the marco below:


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 Dsheet As Worksheet 'destination worksheet
Dim Fsheet As Worksheet 'fan data worksheet (assumed active)

Again:
ColHead = InputBox("Enter Column Heading", "Identify Column", [d1].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

iCol = ColHeadCell.Column
'loop through values in selected column
For iRow = 2 To Fsheet.Cells(65536, iCol).End(xlUp).Row
If Not SheetExists(Fsheet.Cells(iRow, iCol).Value) Then
Set Dsheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
Dsheet.Name = CStr(Fsheet.Cells(iRow, iCol).Value)
Else
Set Dsheet = Worksheets(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





This is taking a specified column and it parse out similar items into new worksheets, and naming the worksheet with that unique value. What I am looking for is an addition or another script that will take the column headers from the orginal data and add it to the subsequent data that the macro parsed out. Currently, there is a blank row on each worksheet that is parsed out. Ideally this would be the Column headers. Thanks for any help!

 

[AlphaFrog]

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

 

[lkohlri]

works perfectly, thank you!