Macro for Multiple Worksheets
Found it. The macro that breaks out my data to multiple tabs creates
an additional blank sheet at the end, called (e.g.) Sheet11. So I end
up with a circular reference on that sheet when I run the next macro
(above). Not sure if there is something I can do to edit the code or a
macro to delete the blank sheet.
Sub BreakoutTabs()
' delete top 3 rows
Rows("2:5").Select
Range("A3").Activate
Selection.Delete Shift:=xlUp
Range("A1").Select
' format worksheet
Selection.AutoFormat Format:=xlRangeAutoFormatList3, Number:=True,
Font:= _
True, Alignment:=True, Border:=True, Pattern:=True,
Width:=True
' begin breakout
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 D
Set rngSrcStart = .Worksheets(strSrcSheet).Range("D2")
Set rngSrcEnd = .Worksheets(strSrcSheet).Range("D65534").End(xlUp)
'set destination row counter
intDestRow = 1
'set last department name
strLastDept = ""
'loop through cells in column D
For Each rngCell In Range(rngSrcStart, rngSrcEnd)
'test if policy info 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.Cop y _
Destination:=.Worksheets(rngCell.Text).Range("A1")
'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
ErrHnd:
Err.Clear
End Sub
|