create sheets' data from master sheet

I have a macro that may be "ready to use" for parsing rows of data from one sheet to many sheets named for the same values.

Sheet1 to Many Sheets

It not only can parse the rows, it can create the sheets if they are missing.

Show me what you mean in a sample workbook created from the macro and with the stuff manually added that you want.

Click GO ADVANCED and use the paperclip icon to post up a desensitized copy of your workbook.

I didn't see the macro in the file, did you edit it in any way?

Just add this to macro:

        ws.Range("A" & Range(vTitles).Resize(1, 1) _
            .Row & ":A" & LR).EntireRow.Copy Sheets(MyArr(Itm) & "").Range("A1")

    'add total
        With Sheets(MyArr(Itm) & "").Range("A" & Rows.Count).End(xlUp).Offset(3)
            .Value = "Balance:"
            .HorizontalAlignment = xlRight
            .Offset(, 1).Formula = "=SUM(D:E)"
            .Resize(1,2).Font.Bold = True
        End With
        
        ws.Range(vTitles).AutoFilter Field:=vCol

The first and last lines of that code example are already in the macro, add the stuff in the middle.

I have several sheets that I need to use as the source sheet for this macro. I currently use a different macro for each sheet, but it seems to me there is a way to have a variable for the sheet name.

How can I pass in a sheet name to the macro so I can use the same macro for all sheets?

Thanks.

Well "ALL SHEETS" is a dangerous phrase. You mean "all the sheets I want to parse from".

This version has an array added where you can list all the sheet names to parse data from.

Option Explicit

Sub ParseItems()
'Author:    Jerry Beaucaire
'Date:      11/11/2009
'Summary:   Based on selected column, data is filtered to individual sheets
'           Creates sheets and sorts sheets alphabetically in workbook
'           6/10/2010 - added check to abort if only one value in vCol
'           7/22/2010 - added ability to parse numeric values consistently
'           10/16/2010 - add ability to parse multiple data sheets
Dim LR As Long, Itm As Long, vCol As Long
Dim MyCount As Long, RowsCount As Long, TmpCount As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, Oops As Boolean

Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 1
 
'Sheet(s) with data to parse
For Each ws In Sheets(Array("Data", "Data2", "Data3"))

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:Z1"
   
'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row
   RowsCount = RowsCount + LR - 1

'Get a temporary list of unique values from column A
    ws.Columns(vCol).SpecialCells(xlConstants).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

'Sort the temporary list
    ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), _
        Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

'Put list into an array for looping
'(values cannot be the result of formulas, must be constants)
    MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE1:EE" _
        & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
    ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
    ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array
'In case values are numerical, we convert them to text with ""
    For Itm = 2 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm) & ""
    
        If Not Evaluate("=ISREF('" & MyArr(Itm) & "'!A1)") Then    'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(Itm) & ""
        Else                                                      'clear sheet if it exists
            Sheets(MyArr(Itm) & "").Move After:=Sheets(Sheets.Count)
        End If
    
        If Sheets(MyArr(Itm) & "").Range("A1") <> "" Then
            TmpCount = Sheets(MyArr(Itm) & "") _
                .Range("A" & Rows.Count).End(xlUp).Row - 1
                ws.Range("A" & Range(vTitles).Resize(1, 1) _
                .Row & ":A" & LR).Offset(1).EntireRow.Copy _
                    Sheets(MyArr(Itm) & "").Range("A" & Rows.Count).End(xlUp).Offset(1)
            MyCount = MyCount + Sheets(MyArr(Itm) & "") _
                .Range("A" & Rows.Count).End(xlUp).Row - 1 - TmpCount
        Else
            ws.Range("A" & Range(vTitles).Resize(1, 1) _
                .Row & ":A" & LR).EntireRow.Copy Sheets(MyArr(Itm) & "").Range("A1")
            MyCount = MyCount + Sheets(MyArr(Itm) & "") _
                .Range("A" & Rows.Count).End(xlUp).Row - 1
        End If
        
    'add total
        With Sheets(MyArr(Itm) & "").Range("B" & Rows.Count).End(xlUp).Offset(1)
            .Value = "Balance:"
            .HorizontalAlignment = xlRight
            .Offset(, 1).Formula = "=SUM(D:E)"
            .Resize(1, 2).Font.Bold = True
        End With
 
        
        ws.Range(vTitles).AutoFilter Field:=vCol
        Sheets(MyArr(Itm) & "").Columns.AutoFit
    Next Itm
    
'Cleanup
    ws.AutoFilterMode = False
Next ws

'Final response
    MsgBox "Rows with data: " & RowsCount & vbLf & "Rows copied to other sheets: " _
                & MyCount & vbLf & "Hope they match!!"

Application.ScreenUpdating = True
End Sub