Need help modifying a macro

[dave]

Hi. I have a macro that works off of a master sheet and creates a new
worksheet for every block of 25 records.

FirstSheetname = ActiveSheet.Name
Lastrow = Range(Cells(1, 1), Cells(Rows.Count, 1)).End(xlDown).Row
For i = 2 To Lastrow Step 25
NewSheetName = Sheets(FirstSheetname). _
Range("C1").Offset(rowoffset:=i - 1, columnoffset:=0) + "-"
NewSheetName = NewSheetName + Sheets(FirstSheetname).Range("C25").
_
Offset(rowoffset:=i - 1, columnoffset:=0)
Sheets.Add
ActiveSheet.Name = NewSheetName
Sheets(FirstSheetname).Rows("1:1").Copy _
Destination:=Worksheets(NewSheetName).Range("A1")
Sheets(FirstSheetname).Rows("1:25"). _
Offset(rowoffset:=i - 1, columnoffset:=0).Copy _
Destination:=Worksheets(NewSheetName).Range("A2")


I would like to change this so that a new worksheet is created that
has all rows where the data in column B is the same (data is already
in order by column B), so if for example rows 1-19 have ABC in column
B, rows 20-67 have XYZ in colum B, then there would be 2 new worksheet
- the first having rows 1-19 from the original and the second having
rows 20-67 from the original, etc..


Any ideas?


Thanks.

 

[JW]

Below is one way to accomplish this. Place the code in a standard
module and call it from the sheet you want to split up. It is
currently set to filter ol column 2 (B). If you ever need to change
that, simply change the filterColNum to whatever the number of the
column you want to filter on.
Sub ReportSplit()
Dim shSource As Worksheet, shTarget As Worksheet
Dim rgSource As Range, rgUniques As Range, cl As Range
Dim filterColNum As Integer
Dim Uniques As New Collection, Unique
Set shSource = ActiveWorkbook.ActiveSheet
filterColNum = 2
With shSource
Set rgSource = ActiveSheet.UsedRange
Set rgUniques = .Range(Cells(2, filterColNum), _
Cells(Rows.Count, filterColNum).End(xlUp))
End With
On Error Resume Next
For Each cl In rgUniques
Uniques.Add cl.Value, CStr(cl.Value)
Next cl
On Error GoTo 0
Application.ScreenUpdating = False
For Each Unique In Uniques
Worksheets.Add , ActiveSheet
Set shTarget = ActiveSheet
shTarget.Name = Unique
With rgSource
.Columns(filterColNum).AutoFilter 1, Unique
.Copy shTarget.Range("A1")
End With
shSource.AutoFilterMode = False
Next Unique
Application.Goto shSource.Range("A1")
Application.ScreenUpdating = True
End Sub