Create New Worksheets\Workbooks Based on Column Data

[slpswhite]

I have a spreadsheet with a header row and columns A-P. In column H I have multiple names and they do duplicate. I have used the code below and it creates the new worksheets/tabs based on the names in column H and copies over the header. I can't seem to get this to copy over actual data. Part two of this, is I need to use the same data but instead of creating worksheets I need it to create new workbooks for the individual names and copy over the data.

Sub AddManagerTab()
    Dim Cl As Range
    Dim UsdRws As Long
    Dim OSht As Worksheet
Application.ScreenUpdating = False
    Set OSht = Sheets("Raw")
    UsdRws = OSht.Range("H" & Rows.Count).End(xlUp).Row
    OSht.Range("A1:P1").AutoFilter
    With CreateObject("scripting.dictionary")
        For Each Cl In Range("H2:H" & UsdRws)
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Nothing
                OSht.Range("A1:P" & UsdRws).AutoFilter field:=15, Criteria1:=Cl.Value
                Sheets.Add(After:=Sheets(Sheets.Count)).Name = Cl.Value
                OSht.Range("A1:P" & UsdRws).SpecialCells(xlCellTypeVisible).Copy _
                    Sheets(Cl.Text).Range("A1")
            End If
        Next Cl
    End With
    OSht.Range("A1:P").AutoFilter
End Sub

This is code I lifted from here with my changes.

 

[Fluff]

To begin with make this change

OSht.Range("A1:P" & UsdRws).AutoFilter field:=[COLOR=#ff0000]8[/COLOR], Criteria1:=Cl.Value

& see if that works to populate the sheets

 

[slpswhite]

That works and copies all the data, however when its done it is producing a "Method 'Range' of object'_Worksheet' failed. I get what I need but it would be nice to clear this out. I will research mofre on how to create the new workbooks on this data. I might have to pop a question tomorrow.

Thanks so much for the support!

 

[Fluff]

This will do workbooks, rather than sheets (without the error)

Sub AddManagerTab()

    Dim Cl As Range
    Dim UsdRws As Long
    Dim OSht As Worksheet
    Dim Wbk As Workbook
    
Application.ScreenUpdating = False
    Set OSht = Sheets("Raw")
    UsdRws = OSht.Range("H" & Rows.Count).End(xlUp).Row
   
    If OSht.AutoFilterMode Then OSht.AutoFilterMode = False
    With CreateObject("scripting.dictionary")
        For Each Cl In Range("H2:H" & UsdRws)
            If Not .exists(Cl.Value) Then
                .Add Cl.Value, Nothing
                Set Wbk = Workbooks.Add(1)
                OSht.Range("A1:P" & UsdRws).AutoFilter field:=8, Criteria1:=Cl.Value
                OSht.Range("A1:P" & UsdRws).SpecialCells(xlCellTypeVisible).Copy Wbk.Sheets(1).Range("A1")
                Wbk.SaveAs Cl.Value, 52
                Wbk.Close False
            End If
        Next Cl
    End With
    OSht.AutoFilterMode = False
End Sub

 

[slpswhite]

This works but doesn't save the file as an Excel spreadsheet. The last one generated is left on the screen and I can do a save as. The others I can't open up. I tried adding changing the workbook save function to Wbk.SaveAs Cl.Value.xlsx, 52 but this didn't work. I will search a bit to see if I can find an answer.

 

[Fluff]

Try

Wbk.SaveAs Cl.Value & ".xlsx", 51

 

[slpswhite]

This works perfect now! Thanks so much.

 

[Fluff]

Glad to help & thanks for the feedback