Generate Multiple Tabbed Sheets From Master List
Suppose you have a single worksheet, sorted in order by sales reps. Let's say the list contains 100 different sales reps, and your goal is to create a unique worksheet tab for each sales rep (giving a total of 101 worksheets within one workbook). The following example illustrates the code necessary to accomplish this.
For this code structure, you will need the original master worksheet (Sheets(1)) and you must create a FORMATTED 2nd worksheet (Sheets(2)) that will be the target of each sales reps performance. (For this example, I'm using a sorted field called BodyCode, but let's assume it is a sales reps full name).
Comments in the code will guide your coding efforts.
Program Code
Option Explicit
Public Sub CreateBodyCodeSheets()
Dim wksMaster As Worksheet
Dim wksBodyCode As Worksheet
Dim rngKeyRange As Range
Dim C As Range
Dim rngSubTotals As Range
Dim rngBorders As Range
Dim lngLastRowInMaster As Long
Dim lngNumberOfRowsInBodyCodeSheet As Long
Dim intNumberOfBodyCodes As Integer
Dim strLastBodyCode As String
Dim i As Integer
Dim lngStartingRow As Long
Dim lngEndingRow As Long
Dim intSheetToPopulate As Integer
Dim lngTotalsRowNumber As Long
' ********************************************************
' Turn Off Screen Updating
' ********************************************************
Application.ScreenUpdating = False
Set wksMaster = Sheets("2010_2011Sales")
Set wksBodyCode = Sheets("BodyCode")
lngLastRowInMaster = wksMaster.Cells(Rows.Count, "A").End(xlUp).Row
Set rngKeyRange = Range(Cells(5, 1), Cells(lngLastRowInMaster, 1))
strLastBodyCode = wksMaster.Cells(5, 1).Value
intNumberOfBodyCodes = 1
' ********************************************************
' Count The Number of Body Codes
' ********************************************************
For Each C In rngKeyRange
If C.Value <> strLastBodyCode Then
strLastBodyCode = C.Value
intNumberOfBodyCodes = intNumberOfBodyCodes + 1
End If
Next C
' ********************************************************
' Create Sheets For All Body Codes
' ********************************************************
For i = 1 To intNumberOfBodyCodes - 1
Sheets("BodyCode").Copy After:=Sheets(i + 1)
Next i
wksMaster.Select
' ********************************************************
' Copy The Data To the Body Code Sheets
' ********************************************************
strLastBodyCode = wksMaster.Cells(5, 1).Value
lngStartingRow = 5
lngEndingRow = 0
intSheetToPopulate = 1
For Each C In rngKeyRange
If C.Value <> strLastBodyCode Then
lngEndingRow = C.Row - 1
intSheetToPopulate = intSheetToPopulate + 1
Range(wksMaster.Cells(lngStartingRow, 1), wksMaster.Cells(lngEndingRow, 55)).Copy Sheets(intSheetToPopulate).Cells(5, 1)
Sheets(intSheetToPopulate).Name = strLastBodyCode
lngStartingRow = C.Row
strLastBodyCode = C.Value
End If
Next C
' ********************************************************
' Do Last Iteration Copy
' ********************************************************
lngEndingRow = lngLastRowInMaster
intSheetToPopulate = intSheetToPopulate + 1
Range(wksMaster.Cells(lngStartingRow, 1), wksMaster.Cells(lngEndingRow, 55)).Copy Sheets(intSheetToPopulate).Cells(5, 1)
Sheets(intSheetToPopulate).Name = strLastBodyCode
' ********************************************************
' Add Totals To Each Sheet
' ********************************************************
For i = 2 To Sheets.Count
Sheets(i).Select
' *************************************************
' Determine The Number Of Rows In The Worksheet
' *************************************************
lngNumberOfRowsInBodyCodeSheet = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
' ***************************************************************************
' Set the Range Variable To The Location of Grand Totals For Numeric Columns
' This range is one row below the last number in the column(s)
' In the example below, we are summing columns 4 through 39
' ***************************************************************************
Set rngSubTotals = Range(Sheets(i).Cells(lngNumberOfRowsInBodyCodeSheet + 1, 4), Sheets(i).Cells(lngNumberOfRowsInBodyCodeSheet + 1, 55))
' **************************************************************
' Add the formula to compute the totals of all columns
' This worksheet has 4 header lines that are not summed
' **************************************************************
rngSubTotals.FormulaR1C1 = "=SUM(R[-" & lngNumberOfRowsInBodyCodeSheet - 4 & _
"]C:R[-1]C)"
' **************************************************************
' Add Underlines to the Grand Totals Just Created
' **************************************************************
Set rngBorders = Range(Sheets(i).Cells(lngNumberOfRowsInBodyCodeSheet + 1, 4), Sheets(i).Cells(lngNumberOfRowsInBodyCodeSheet + 1, 55))
With rngBorders.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With rngBorders.Borders(xlEdgeBottom)
.LineStyle = xlDouble
.Weight = xlThick
.ColorIndex = xlAutomatic
End With
lngTotalsRowNumber = lngNumberOfRowsInBodyCodeSheet + 1
' ********************************************************
' Autofit All The Columns Of The Current Sheet
' ********************************************************
Sheets(i).Cells.Columns.AutoFit
Sheets(i).Cells(1, 1).Select
Next i
wksMaster.Select
wksMaster.Cells(1, 1).Select
' ********************************************************
' Turn On Screen Updating
' ********************************************************
Application.ScreenUpdating = True
End Sub