VBA - One sheet to become many based on one variable

[fortheloveofgod]

Hi all

I have toiled and toiled with this hence the name I chose.

Basically I produce an excel sheet each month, in column A is a Id, this Id can be repeated for several rows (varies) - what I need to do is create new workbooks for each Id and pull the data from the original table through too, so create new work books based on that Id and the corresponding info

I could do filters etc for each of the known Ids (about 127) and then copy this into a new sheet but it would be messy and very rough code based on recording and trial and error

I found this code which can create new workbooks for each of the Ids,

can anyone help pulling through the data? at the moment its populating the field names only from the top of the document

Option Explicit

Sub CreateWorkbooks()

    Dim strMyPath As String
    Dim wkbNew As Workbook
    Dim wksNew As Worksheet
    Dim rUniqueVals As Range
    Dim rCell As Range
    Dim LastRow As Long
    Dim LastColumn As Long
    
    With ActiveSheet.UsedRange
        LastRow = .Rows.Count + .Rows(1).Row - 1
        LastColumn = .Columns.Count + .Columns(1).Column - 1
    End With
    
    If LastRow > 1 Then
    
        Application.ScreenUpdating = False
    
        strMyPath = "\\my file for the docs to be created"
        
        If Right(strMyPath, 1) <> "\" Then strMyPath = strMyPath & "\"
        
        With Range(Cells(1, 1), Cells(LastRow, LastColumn))
            .Sort key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes, _
                ordercustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        End With
        
        Range("A1:A" & LastRow).AdvancedFilter xlFilterInPlace, , , True
        
        Set rUniqueVals = Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
        
        For Each rCell In rUniqueVals
            With ActiveSheet.UsedRange
                .AutoFilter Field:=5, Criteria1:=rCell.Value
                .Copy
            End With
            Set wkbNew = Workbooks.Add(xlWBATWorksheet)
            Set wksNew = wkbNew.Worksheets(1)
            wksNew.Range("A1").PasteSpecial
            wkbNew.SaveAs strMyPath & rCell.Value & ".xlsx", 51
            wkbNew.Close False
        Next rCell
        
        ActiveSheet.ShowAllData
        
        Application.ScreenUpdating = True
        
        MsgBox "Completed...", vbInformation
        
    Else
    
        MsgBox "No data is available...", vbExclamation
        
    End If
    
End Sub

Thanks guys, would help me a lot

[Mordred]

Hi fortheloveofgod and welcome to the forum. I am going to change your tags to be code tags instead of quote tags and I would ask that you use code tags in the future (for code examples). You could type in the tags by using the following example
[CODE]Sub YourCode()[/CODE]

Thanks!

[royUK]

here's some basic code that should work for you with some slight tweaking to suit.

Option Explicit

'---------------------------------------------------------------------------------------
' 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 = Sheet1

    'extract a list of unique names
    'first clear existing list
    With ws
.range containing data, table will be picked up automatically
'change cells(1,1) if table does not start in A1
        Set rData = .Range(.Cells(1, 1).CurrentRegion
        .Columns(.Columns.Count).Clear
        .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).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
.currently categories in Column C, change AutoFilter Field for different Column
            'AutoFilter & copy to relevant sheet
            rData.AutoFilter Field:=3, 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

[fortheloveofgod]

Thanks guys, sorry about the wrong quote thing, i'll go have a play with that code, thank you so much for the help!

Hopefully I can help some people rather than just being a pain, my VBA leaves a lot to be desired though.