Filter data onto new sheets, re-name sheets

Microsoft Excel 2003 (full product)
January 14, 2010 at 16:47:10
Specs: Windows XP
Hi there,

I need a macro to create new spreadsheets based on sorted data, pulling all of the data assoc. with that # onto a new spreadsheet . Column B has facility numbers (multiple rows per facility number) at each change in Column B, I need all the same numbers copied to a new worksheet (worksheet would then be named whatever number it pulled).
Example (Sheet1)
Column1 Column2 Column 3
1 1101 Someplace
1 1101 Someplace
1 1102 Someplace else
1 1102 Someplace else

All of the '1101' need to be on a new sheet named '1101' all of the '1102' need to be on a new sheet named '1102' etc. This number goes all the way to 1300 so I would end up with 200 different sheets...Is there any hope for me??

See More: Filter data onto new sheets, re-name sheets

January 15, 2010 at 05:50:38

The following macro will create new tabs for each department and copy the information for each department into the appropriate tab.
The headings on the source worksheet will also be copied to the first row of each new worksheet created.

The source data worksheets must be named SrcData
(or change the tab name here

'name of source data worksheet (tab)
strSrcSheet = "SrcData")

The Macro assumes that department ID's are in column B starting on row 2 (cell B2) on the SrcData sheet.
Data starts in row 2 to leave a row for Headings.
It also requires that there is no other information in column B below the last department ID.

Here is the code:

Option Explicit

Private Sub DeptTabs()
Dim strSrcSheet As String
Dim rngSrcStart As Range
Dim rngSrcEnd As Range
Dim rngCell As Range
Dim strLastDept As String
Dim intDestRow As Integer

On Error GoTo ErrHnd

'name of source data worksheet (tab)
strSrcSheet = "SrcData"

With ActiveWorkbook
    'setup source range in column B
    Set rngSrcStart = .Worksheets(strSrcSheet).Range("B2")
    Set rngSrcEnd = .Worksheets(strSrcSheet).Range("B65534").End(xlUp)
    'set destination row counter
    intDestRow = 1
    'set last department name
    strLastDept = ""

    'loop through cells in column B
    For Each rngCell In Range(rngSrcStart, rngSrcEnd)
        'test if department ID change
        If rngCell.Text <> strLastDept Then
            'create new sheet
            .Worksheets.Add After:=.Worksheets(Worksheets.Count)
            'name new sheet
            .Worksheets(Worksheets.Count).Name = rngCell.Text
            'copy header row
            .Worksheets(strSrcSheet).Range("A1").EntireRow.Copy _
            'reset variables
            strLastDept = rngCell.Text
            intDestRow = 1
        End If
        'copy entire row
        rngCell.EntireRow.Copy _
            Destination:=.Worksheets(strLastDept).Range("A1").Offset(intDestRow, 0)
        'increment row counter
        intDestRow = intDestRow + 1
    Next rngCell
End With
Exit Sub
'error handler
End Sub


Report •

January 15, 2010 at 08:18:33
You, Humar, are an absolute Genius and lifesaver! That Macro worked like a dream! Thank you so very, very much...

Report •
Related Solutions

Ask Question