Split large sheet into several smaller sheets for emailing
 

I need to split large datasheet (over 20,000 rows) into separate worksheets,
which will then be emailed to individuals.

My problem that the data is in 10 columns and col 1 may contain from 1 to 95
items that are identical in the first cell.

What I need is the ability to compare A2 with A3 and if the same then A4
with A3 and so on until A(x) is compared with the previous cell and at that
point create a new worksheet.
An additional nice touch would be to name the worksheet with the contents of
the cell A1 and subsequent data changes.
Example data:
A B C
1 Fred Dog Cat
2 Fred Fish Apple
3 Joe Item1 Item2
4 Joe Item1 Item3
5 Joe Item 2 Item3
In this case a new Worksheet would be created between Fred and Joe.
I have used the code below from another post that does part of this but am
stuck on the rest.

Sub Make_Reports()

Dim iReport As Integer
Dim lRow As Long
Dim wsReport As Worksheet
Dim wsData As Worksheet

'speed things up a bit
Application.ScreenUpdating = False

iReport = 1
lRow = 2 'assumes first row is header row
Set wsData = ActiveSheet

Do While wsData.Cells(lRow, 1).Formula < ""
'add new worksheet for new report
Set wsReport = Worksheets.Add
wsReport.Name = "Report " & iReport
'copy headers
wsData.Range("A1:J1").Copy _
Destination:=wsReport.Range("A1")
'copy data (25 rows * 10 columns
wsData.Cells(lRow, 1).Resize(25, 10).Copy _
Destination:=wsReport.Range("A2")

End Sub




Thanks in advance for all your help

Don

Split large sheet into several smaller sheets for emailing
 

Don

Try this

Sub Make_Reports()

Dim iReport As Long
Dim lRow As Long
Dim wsReport As Worksheet
Dim wsData As Worksheet

iReport = 1
lRow = 2 'assumes first row is header row
Set wsData = ActiveSheet

Do While Not IsEmpty(wsData.Cells(lRow, 1))

With wsData
If .Cells(lRow, 1).Value < _
.Cells(lRow, 1).Offset(-1, 0).Value Then

'add new worksheet for new report
Set wsReport = Worksheets.Add
wsReport.Name = "Report " & .Cells(lRow, 1).Value

'copy headers
.Range("A1:J1").Copy _
Destination:=wsReport.Range("A1")
End If

.Cells(lRow, 1).EntireRow.Copy _
wsReport.Range("A65536").End(xlUp).Offset(1, 0)
End With
lRow = lRow + 1
Loop

End Sub

--
Dick Kusleika
MVP - Excel
www.dicks-clicks.com
Post all replies to the newsgroup.

"diverdon99" wrote in message
...
I need to split large datasheet (over 20,000 rows) into separate
worksheets,
which will then be emailed to individuals.

My problem that the data is in 10 columns and col 1 may contain from 1 to
95
items that are identical in the first cell.

What I need is the ability to compare A2 with A3 and if the same then A4
with A3 and so on until A(x) is compared with the previous cell and at
that
point create a new worksheet.
An additional nice touch would be to name the worksheet with the contents
of
the cell A1 and subsequent data changes.
Example data:
A B C
1 Fred Dog Cat
2 Fred Fish Apple
3 Joe Item1 Item2
4 Joe Item1 Item3
5 Joe Item 2 Item3
In this case a new Worksheet would be created between Fred and Joe.
I have used the code below from another post that does part of this but am
stuck on the rest.

Sub Make_Reports()

Dim iReport As Integer
Dim lRow As Long
Dim wsReport As Worksheet
Dim wsData As Worksheet

'speed things up a bit
Application.ScreenUpdating = False

iReport = 1
lRow = 2 'assumes first row is header row
Set wsData = ActiveSheet

Do While wsData.Cells(lRow, 1).Formula < ""
'add new worksheet for new report
Set wsReport = Worksheets.Add
wsReport.Name = "Report " & iReport
'copy headers
wsData.Range("A1:J1").Copy _
Destination:=wsReport.Range("A1")
'copy data (25 rows * 10 columns
wsData.Cells(lRow, 1).Resize(25, 10).Copy _
Destination:=wsReport.Range("A2")

End Sub




Thanks in advance for all your help

Don

Split large sheet into several smaller sheets for emailing
 

Dick,

A very big thank you for your help. This code works like a charm.
I have had 48 hours of beating my head against the wall trying to find a
solution on my own.I am now in a position to complete the code today as the
deadline was set for Wednesday.
I cannot begin to tell you the help this has been.
A very merry Christmas to you.

Don


Try this

Sub Make_Reports()

Dim iReport As Long
Dim lRow As Long
Dim wsReport As Worksheet
Dim wsData As Worksheet

iReport = 1
lRow = 2 'assumes first row is header row
Set wsData = ActiveSheet

Do While Not IsEmpty(wsData.Cells(lRow, 1))

With wsData
If .Cells(lRow, 1).Value < _
.Cells(lRow, 1).Offset(-1, 0).Value Then

'add new worksheet for new report
Set wsReport = Worksheets.Add
wsReport.Name = "Report " & .Cells(lRow, 1).Value

'copy headers
.Range("A1:J1").Copy _
Destination:=wsReport.Range("A1")
End If

.Cells(lRow, 1).EntireRow.Copy _
wsReport.Range("A65536").End(xlUp).Offset(1, 0)
End With
lRow = lRow + 1
Loop

End Sub

--
Dick Kusleika
MVP - Excel
www.dicks-clicks.com
Post all replies to the newsgroup.

"diverdon99" wrote in message
...
I need to split large datasheet (over 20,000 rows) into separate
worksheets,
which will then be emailed to individuals.

My problem that the data is in 10 columns and col 1 may contain from 1
to
95
items that are identical in the first cell.

What I need is the ability to compare A2 with A3 and if the same then A4
with A3 and so on until A(x) is compared with the previous cell and at
that
point create a new worksheet.
An additional nice touch would be to name the worksheet with the
contents
of
the cell A1 and subsequent data changes.
Example data:
A B C
1 Fred Dog Cat
2 Fred Fish Apple
3 Joe Item1 Item2
4 Joe Item1 Item3
5 Joe Item 2 Item3
In this case a new Worksheet would be created between Fred and Joe.
I have used the code below from another post that does part of this but
am
stuck on the rest.

Sub Make_Reports()

Dim iReport As Integer
Dim lRow As Long
Dim wsReport As Worksheet
Dim wsData As Worksheet

'speed things up a bit
Application.ScreenUpdating = False

iReport = 1
lRow = 2 'assumes first row is header row
Set wsData = ActiveSheet

Do While wsData.Cells(lRow, 1).Formula < ""
'add new worksheet for new report
Set wsReport = Worksheets.Add
wsReport.Name = "Report " & iReport
'copy headers
wsData.Range("A1:J1").Copy _
Destination:=wsReport.Range("A1")
'copy data (25 rows * 10 columns
wsData.Cells(lRow, 1).Resize(25, 10).Copy _
Destination:=wsReport.Range("A2")

End Sub




Thanks in advance for all your help

Don

Split large sheet into several smaller sheets for emailing
 

Don

You're welcome and same to you.

Dick

"diverdon99" wrote in message
...
Dick,

A very big thank you for your help. This code works like a charm.
I have had 48 hours of beating my head against the wall trying to find a
solution on my own.I am now in a position to complete the code today as
the
deadline was set for Wednesday.
I cannot begin to tell you the help this has been.
A very merry Christmas to you.

Don


Try this

Sub Make_Reports()

Dim iReport As Long
Dim lRow As Long
Dim wsReport As Worksheet
Dim wsData As Worksheet

iReport = 1
lRow = 2 'assumes first row is header row
Set wsData = ActiveSheet

Do While Not IsEmpty(wsData.Cells(lRow, 1))

With wsData
If .Cells(lRow, 1).Value < _
.Cells(lRow, 1).Offset(-1, 0).Value Then

'add new worksheet for new report
Set wsReport = Worksheets.Add
wsReport.Name = "Report " & .Cells(lRow, 1).Value

'copy headers
.Range("A1:J1").Copy _
Destination:=wsReport.Range("A1")
End If

.Cells(lRow, 1).EntireRow.Copy _
wsReport.Range("A65536").End(xlUp).Offset(1, 0)
End With
lRow = lRow + 1
Loop

End Sub

--
Dick Kusleika
MVP - Excel
www.dicks-clicks.com
Post all replies to the newsgroup.

"diverdon99" wrote in message
...
I need to split large datasheet (over 20,000 rows) into separate
worksheets,
which will then be emailed to individuals.

My problem that the data is in 10 columns and col 1 may contain from 1
to
95
items that are identical in the first cell.

What I need is the ability to compare A2 with A3 and if the same then
A4
with A3 and so on until A(x) is compared with the previous cell and at
that
point create a new worksheet.
An additional nice touch would be to name the worksheet with the
contents
of
the cell A1 and subsequent data changes.
Example data:
A B C
1 Fred Dog Cat
2 Fred Fish Apple
3 Joe Item1 Item2
4 Joe Item1 Item3
5 Joe Item 2 Item3
In this case a new Worksheet would be created between Fred and Joe.
I have used the code below from another post that does part of this
but
am
stuck on the rest.

Sub Make_Reports()

Dim iReport As Integer
Dim lRow As Long
Dim wsReport As Worksheet
Dim wsData As Worksheet

'speed things up a bit
Application.ScreenUpdating = False

iReport = 1
lRow = 2 'assumes first row is header row
Set wsData = ActiveSheet

Do While wsData.Cells(lRow, 1).Formula < ""
'add new worksheet for new report
Set wsReport = Worksheets.Add
wsReport.Name = "Report " & iReport
'copy headers
wsData.Range("A1:J1").Copy _
Destination:=wsReport.Range("A1")
'copy data (25 rows * 10 columns
wsData.Cells(lRow, 1).Resize(25, 10).Copy _
Destination:=wsReport.Range("A2")

End Sub




Thanks in advance for all your help

Don