Create Multiple Worksheets from One

[Kdub via OfficeKB.com]

I have a worksheet that contains about 3000 rows. I would like to cut data
from this worksheet and copy all data whenever the value in column C
changes. For example, for this worksheet:

A B C
163 4/4/2005 51
168 4/2/2005 51
123 4/5/2005 62
128 4/1/2005 62
187 4/9/2005 71

I need to create three new worksheets, the first containing rows 1 and 2,
the second containing rows 3 and 4, and the third containing row 5. I'm
not sure of the best way to go about this. Any suggestions welcome.

[Ron de Bruin]

See
http://www.rondebruin.nl/copy5.htm

--
Regards Ron de Bruin
http://www.rondebruin.nl


"Kdub via OfficeKB.com" <[email protected]> wrote in message news:[email protected]...
>I have a worksheet that contains about 3000 rows. I would like to cut data
> from this worksheet and copy all data whenever the value in column C
> changes. For example, for this worksheet:
>
> A B C
> 163 4/4/2005 51
> 168 4/2/2005 51
> 123 4/5/2005 62
> 128 4/1/2005 62
> 187 4/9/2005 71
>
> I need to create three new worksheets, the first containing rows 1 and 2,
> the second containing rows 3 and 4, and the third containing row 5. I'm
> not sure of the best way to go about this. Any suggestions welcome.

[STEVE BELL]

(untested code)

You could loop each row and copy each:

==========================================
Dim lrw1 as long, lrw2 as long, rw1 as long

lrw1 = ActiveSheet.Cells(Rows.COUNT, "A").Row

lrw2 = Sheets(ActiveSheet.Cells(1,3).Text).Cells(Rows.COUNT, "A").Row ' or
however you identify your sheet to paste to

Activesheet.Rows(1).Copy _
Destination:=Sheets(ActiveSheet.Cells(1,3).Text).Cells(1,lrw2)

For rw1 = 2 to lrw1
lrw2 = Sheets(ActiveSheet.Cells(rw1,1).Text) ' or however you identify
your sheet to paste to

Activesheet.Rows(rw1).Copy _
Destination:=Sheets(ActiveSheet.Cells(rw1,3).Text).Cells(1,lrw2)

Next
=============================================
You might also try:

Sheets("paste to sheet").Rows(lrw2)=Sheets("master sheet").Rows(lrw1)

The trick is transforming column C into a sheet reference.

Don't know how long this will take.

You could get creative and define blocks of rows to paste...

--
steveB

Remove "AYN" from email to respond
"Kdub via OfficeKB.com" <[email protected]> wrote in message
news:[email protected]...
>I have a worksheet that contains about 3000 rows. I would like to cut data
> from this worksheet and copy all data whenever the value in column C
> changes. For example, for this worksheet:
>
> A B C
> 163 4/4/2005 51
> 168 4/2/2005 51
> 123 4/5/2005 62
> 128 4/1/2005 62
> 187 4/9/2005 71
>
> I need to create three new worksheets, the first containing rows 1 and 2,
> the second containing rows 3 and 4, and the third containing row 5. I'm
> not sure of the best way to go about this. Any suggestions welcome.

[Kdub via OfficeKB.com]

Here's what I ended up doing. Works great.

This creates multiple sheets from one master, loops through to perform
edits on every sheet, then combines all the data back into the master,
deleting the intermediate worksheets. Takes about 4 sec. for 5000 rows

Dim LastRow, LastCol, MasterLastRow As Long
Dim WBName As String
Dim ReplaceValue, NewName, DMName As String
Dim CopyRange, r, rng, MasterRange As Range
Dim SheetArray(), SheetCount, I, P, MyLoc As Integer
Dim First As Boolean

Application.ScreenUpdating = False
First = True
MyLoc = InStr(1, ActiveWorkbook.Name, ".")
WBName = Left(ActiveWorkbook.Name, MyLoc - 1)
SheetCount = 0
ActiveSheet.Name = "MyMaster"
CurrentStore = Range("C1").Value
LastRow = (Cells(Rows.Count, 3).End(xlUp).Row)
LastCol = Cells(2, Columns.Count).End(xlToLeft).Column
Range("C1").Activate
Do While CurrentStore <> ""
If ActiveCell.Value <> CurrentStore Then
CopyRange = Range(Cells(1, 1), Cells(ActiveCell.Row - 1, LastCol))
..Address
Range(CopyRange).Select
Selection.Copy
SheetName = WBName & "-" & CurrentStore
Worksheets.Add
SheetCount = SheetCount + 1
ActiveSheet.Name = SheetName
ActiveSheet.Paste
Rows(1).Insert
Range("A1").Value = CurrentStore
Sheets("MyMaster").Activate
Selection.Delete xlUp
Range("C1").Activate
CurrentStore = ActiveCell.Value
End If
ActiveCell.Offset(1, 0).Activate
Loop

For I = 1 To Sheets.Count
If Sheets(I).Name = "MyMaster" Then
GoTo MyNext
End If
Sheets(I).Activate
Columns(5).Delete
Columns(4).Delete
Columns(3).Delete
Columns(2).Delete
CurrentStore = Range("A1").Value
Rows(1).Delete
Call InsertFirstColandFormat
Call ModifyUOM
Call InsertHeaderAndFooter
MyNext:
Next I

For P = 1 To Sheets.Count
If Sheets(P).Name = "MyMaster" Then
GoTo PasteNext
End If
Sheets(P).Activate
LastRow = (Cells(Rows.Count, 3).End(xlUp).Row)
LastCol = Cells(2, Columns.Count).End(xlToLeft).Column
'Paste all sheets back into master
CopyRange = Range(Cells(1, 1), Cells(LastRow, LastCol)).Address
Range(CopyRange).Select
Selection.Copy
Sheets("MyMaster").Activate
If First = True Then
First = False
Range("A1").Select
Else
MasterLastRow = ActiveSheet.Cells.Find(What:="*", _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row + 1
Range(Cells(MasterLastRow, 1), Cells(MasterLastRow, 1)).Cells.Select
'Range(MasterRange).Select
End If

ActiveSheet.Paste
PasteNext:
Next P

'Delete Extra worksheets
Application.DisplayAlerts = False
Do While Sheets.Count > 1
If Sheets(1).Name <> "MyMaster" Then
Sheets(1).Activate
Sheets(1).Delete
End If
Loop
Application.ScreenUpdating = True
End Sub

--
Message posted via http://www.officekb.com