Move data to cell sheets

You want to add a sheet named as the value in A1, containing that row?

What about the other names?

Do you want a sheet for each name

Option Explicit

Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

Sub moveRow()
    Dim aWs    As Worksheet
    Dim rng    As Range
    Dim cl     As Range
    Dim sShtNm As String

    Set aWs = Sheets("Sheet1")
    With aWs
        Set rng = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
        For Each cl In rng
            sShtNm = cl.Value
            If Not WksExists(sShtNm) Then
                Sheets.Add
                ActiveSheet.Name = sShtNm
                cl.EntireRow.Copy Sheets(sShtNm).Cells(1, 1)
            End If
        Next cl
    End With
End Sub

Please mark the thread solved & rate the answer.

Please ask the full question at first instead of in stages. We could have resolved this immediately instead of over 3 or 4 attempts.

Does your data have header rows?

Here's an earlier post with a similar request

http://www.excelforum.com/excel-prog...n-keyword.html

You haven't adjusted the code correctly to ork with the right sheet or columns

Option Explicit
'---------------------------------------------------------------------------------------
' Module    : Module1
' DateTime  : 24/09/2006 22:48
' Author    : Roy Cox (royUK)
' Website   :  more examples
' Purpose   :  Create a sheet for each unique name in data
' Disclaimer; This code is offered as is with no guarantees. You may use it in your
'             projects but please leave this header intact.
'---------------------------------------------------------------------------------------

Sub ExtractToSheets()
    Dim ws     As Worksheet
    Dim wsNew  As Worksheet
    Dim rData  As Range
    Dim rCl    As Range
    Dim sNm    As String
    Set ws = Sheets("Sheet2")

    'extract a list of unique names
    'first clear existing list
    With ws
        Set rData = .Range(.Cells(1, 1), .Cells(.Rows.Count, 11).End(xlUp))
        .Columns(.Columns.Count).Clear
        .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

        For Each rCl In .Range(.Cells(1, .Columns.Count), .Cells(.Rows.Count, .Columns.Count).End(xlUp))
            sNm = rCl.Text
            'add new sheet (only if required-NB uses UDF)
            If WksExists(sNm) Then
                'so clear contents
                Sheets(sNm).Cells.Clear
            Else
                'new sheet required
                Set wsNew = Sheets.Add
                wsNew.Move After:=Worksheets(Worksheets.Count)    'move to end
                wsNew.Name = sNm
            End If
            'AutoFilter & copy to relevant sheet
            rData.AutoFilter Field:=1, Criteria1:=sNm
            rData.Copy Destination:=Worksheets(sNm).Cells(1, 1)
        Next rCl
   End With
    ws.Columns(Columns.Count).ClearContents        'remove temporary list
    rData.AutoFilter        'switch off AutoFilter
End Sub

Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function