Parse Functions‎ > ‎

Sheet1 to Sheets

PART 1 - Show Data From Master on Individual Sheets (non-macro)

 
This first workbook demonstrates a non-vba way to show data from a main "database" sheet on sub-sheets based on a key piece of information on each row of data in the database. This example shows "accounts" on sheets named after the "managers" assigned to each account.
 
Sample Workbook:  Sheet1toSheets-ParseMacro.xls 
PART 2 - Parse New Data To New Sheets (macro)
 
PROBLEM: 
"I have a master sheet with all data on it. I need to parse this data out to individual sheet based on the values in a single column.  The individual sheets may or may not exist already. If they exist, the data from the master should replace what is on the sub sheet. The sub sheet should be created when needed."
 
SPECIFICATION: 
  1. Titles are in row 1 and will be duplicated on all sheets
  2. Column to evaluate from should be easily adjustable, sometimes we parse by column A, other times by column B, etc.
  3. Values to parse by may be numerical which is problematic in sheetname creation/referencing at times, solve for that
  4. Sheets should be created as needed
  5. Data is optionally appended on any already existing sheets, or data is cleared each time macro runs
This macro will accomplish this. Only the first 3 lines need editing for the vCol, ws name and vTitles range.
 

CODE

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
'           11/16/2011 - changed way Unique values are collected, no Adv Filter
'           12/23/2013 - option to append incoming data
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long, iCol As Long, NR As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String, TitleRow As Long, Append As Boolean

Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 1
 
'Sheet with data in it
   Set ws = Sheets("Data")

'option to append new data below old data
If MsgBox(" If sheet exists already, add new data to the bottom?" & vbLf & _
           "(if no, new data will replace old data)", _
           vbYesNo, "Append new Data?") = vbYes Then Append = True

'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"
    TitleRow = Range(vTitles).Cells(1).Row

'Spot bottom row of data
   LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Get a temporary list of unique values from vCol
    iCol = ws.Columns.Count
    ws.Cells(1, iCol) = "key"
   
    For Itm = TitleRow + 1 To LR
        On Error Resume Next
        If ws.Cells(Itm, vCol) <> "" And Application.WorksheetFunction _
            .Match(ws.Cells(Itm, vCol), ws.Columns(iCol), 0) = 0 Then
               ws.Cells(ws.Rows.Count, iCol).End(xlUp).Offset(1) = ws.Cells(Itm, vCol)
        End If
    Next Itm
'Sort the temporary list
    ws.Columns(iCol).Sort Key1:=ws.Cells(2, iCol), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

'Put list into an array for looping
    MyArr = Application.WorksheetFunction.Transpose _
        (ws.Columns(iCol).SpecialCells(xlCellTypeConstants))

'clear temporary list
    ws.Columns(iCol).Clear

'Turn on the autofilter
    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
    For Itm = 2 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=CStr(MyArr(Itm))
   
        If Not Evaluate("=ISREF('" & CStr(MyArr(Itm)) & "'!A1)") Then   'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(MyArr(Itm))
            NR = 1
        Else                                                            'if it exists already
            Sheets(CStr(MyArr(Itm))).Move After:=Sheets(Sheets.Count)   'ordering the sheets
            If Append Then                                              'find next empty row
                NR = Sheets(CStr(MyArr(Itm))).Cells(Rows.Count, vCol).End(xlUp).Row + 1
            Else
                Sheets(CStr(MyArr(Itm))).Cells.Clear                    'clear data if not appending
                NR = 1
            End If
        End If
   
        If NR = 1 Then                                                  'copy titles and data
            ws.Range("A" & TitleRow & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
        Else                                                            'copy data only
            ws.Range("A" & TitleRow + 1 & ":A" & LR).EntireRow.Copy Sheets(CStr(MyArr(Itm))).Range("A" & NR)
        End If
       
        ws.Range(vTitles).AutoFilter Field:=vCol                        'reset the autofilter
        If Append And NR > 1 Then NR = NR - 1
        MyCount = MyCount + Sheets(CStr(MyArr(Itm))).Range("A" & Rows.Count).End(xlUp).Row - NR
        Sheets(CStr(MyArr(Itm))).Columns.AutoFit
    Next Itm
   
'Cleanup
    ws.Activate
    ws.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - TitleRow) & vbLf & "Rows copied to other sheets: " _
                & MyCount & vbLf & "Hope they match!!"

    Application.ScreenUpdating = True
End Sub

  

Nothing says "thanks" like a steak dinner!
 
PayPal - The safer, easier way to pay online!
 
Comments