VBA to create new worksheets in Excel 2013

[pharris81]

Hello,

I'm trying to construct a macro that will take a name from a list in worksheet "Names", and apply the name in a text filter (ie. text filter > contains) in column A of worksheet "Data", copy all rows after the filter has been applied and paste them to a new worksheet with the same name as the individual. It then needs to continue to loop until it has been through all the names in the list.

I've provided a little more detail below. I thought I'd just write out the gist of it so people don't have to read the whole lot to decide if they're interested.

In worksheet "Names", there is a header "Names" in A1, with names listed beneath it.

In worksheet "Data", column A contains survey questions that will contain an individual's name eg. "Please rate Joe Bloggs's customer service." Or "Has Joey McJoe-Joe demonstrated leadership?" with marks listed in columns B, C, D etc

I am trying to take the name from cell A2, apply it in column A of worksheet "Data" in a text filter > contains "Joe Bloggs", take all results, create a worksheet called "Joe Bloggs" and Paste Special Formulas into the new worksheet (I have calculations which need to be transferred and not simply values). The macro then needs to loop through the names in the list until "Data" has been filtered for each individual and all the necessary worksheets created.

I made a start and have the following code:

Sub Create_Sheets()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String

    Set wSheetStart = Sheets("Data")
    wSheetStart.AutoFilterMode = False
    'Set a range variable to the correct item column
    Set rRange = Sheets("Data").Range("A1", Range("A65536").End(xlUp))
    
        On Error Resume Next
        Application.DisplayAlerts = False
                
                
                 'Set a range variable to the unique list, less the heading.
                 Set rRange = .Range("A2", .Range("A65536").End(xlUp))
            End With
            
            On Error Resume Next
            With wSheetStart
                For Each rCell In rRange
                  strText = rCell
                 .Range("A1").AutoFilter 1, strText
                    Worksheets(strText).Delete
                    'Add a sheet named as content of rCell
                    Worksheets.Add().Name = strText
                    'Copy the visible filtered range _
                    (default of Copy Method) and leave hidden rows
                    .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
                    ActiveSheet.Cells.Columns.AutoFit
                Next rCell
            End With
            
        With wSheetStart
            .AutoFilterMode = False
            .Activate
        End With
        
        On Error GoTo 0
        Application.DisplayAlerts = True
End Sub

I know the code above won't work. It's probably more hindrance than help for people trying to understand what is going on. It's just a hatchet job I've been able to cobble together.

If anyone knows how I might be able to do this, your assistance would be greatly appreciated.

Thanks very much.
Peter