Insert Worksheets based on column data.

[malycom]

Hi everyone

I run a report that creates a 7 coumn spreadsheet analysing staff time
through a week.

The last column (G) uses a staff code and is sorted in ascending order.

What I would like to do is to run a macro or program that will go through
the spreadsheet and create a new worksheet for each Staff code, naming the
worksheet exactly the same, and inserting all the rows of data belonging to
each staff code into its individual worksheet.

For instance, if one of the Staff codes in the original pages is TW and
there are 9 rows of data for TW, I would like a worksheet inserted called TW
and then all those 9 rows of data copied into it from say Row B. In the main
sheet there are a load of heading in row A which ideally could also be copied
into Row A of each worksheet.

As much detail as possible would be really appreciated here as I don't have
a clue how to go about it.

Thanks in advance

Malcolm Davzidson

 

[Mike H]

Hi,

Not extensively tested but try this

Sub stantial()
Dim MyRange As Range, CopyRange As Range
Dim lastrow As Long
Set sht = Sheets("Sheet1")' Change to suit
lastrow = sht.Cells(Cells.Rows.Count, "G").End(xlUp).Row
Set MyRange = sht.Range("G1:G" & lastrow)
For Each c In MyRange
If c.Value = c.Offset(1).Value Then
If CopyRange Is Nothing Then
Set CopyRange = c.EntireRow
Else
Set CopyRange = Union(CopyRange, c.EntireRow)
End If
Else
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = c.Value
CopyRange.Resize(CopyRange.Rows.Count + 1).Copy _
Destination:=Sheets(c.Value).Range("A1")
sht.Activate
Set CopyRange = Nothing
End If
Next
End Sub


--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.

 

[malycom]

Mike

First impressions look amazing.

Done a couple of random checks and so far all the data is correct.

Now, not meaning to be greedy as what you have done so far is fantastic, but
is there a way of adding something that will auto sum colum B and auto sum
column C and also make columns B & C so they format as number to two decimal
points.

I appreciate if that's a question to far but you appear to be a Ninja with
Excel.

Once again, thanks for what you have done.

Regards

Malcolm Davidson

 

[Ryan H]

Is your staff data in Col. G sorted? I believe Mikes code works beautifully
if it is sorted. I basically tweaked Mikes code. Hope this helps! If so,
let me know, click "YES" below.

Sub stantial()

Dim MyRange As Range
Dim CopyRange As Range
Dim lastrow As Long

Set sht = Sheets("Sheet1") ' Change to suit
lastrow = sht.Cells(Cells.Rows.Count, "G").End(xlUp).Row
Set MyRange = sht.Range("G1:G" & lastrow)

For Each c In MyRange
If c.Value = c.Offset(1).Value Then
If CopyRange Is Nothing Then
Set CopyRange = c.EntireRow
Else
Set CopyRange = Union(CopyRange, c.EntireRow)
End If
Else
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = c.Value
CopyRange.Resize(CopyRange.Rows.Count + 1).Copy _
Destination:=Sheets(c.Value).Range("A1")
sht.Activate
Set CopyRange = Nothing

' add sum formula at end of Col.B & Col. C
With wks
lastrow = .Cells(Rows.Count, "G").End(xlUp).Row
.Cells(lastrow + 1, "B").Formula = "=SUM(B2:B" & lastrow & ")"
.Cells(lastrow + 1, "C").Formula = "=SUM(C2:C" & lastrow & ")"

' number format
.Range("B2:B" & lastrow + 1).NumberFormat = "0.00"
.Range("C2:C" & lastrow + 1).NumberFormat = "0.00"
End With

End If
Next c

End Sub

 

[Mike H]

Hi,

This should take care of the summing and number formatting but because I
have included NO error checking you will get an error if you try and run the
code again because the shhet being added will already exist so you must
delete these sheets before re-running the code

Sub stantial()
Dim MyRange As Range, CopyRange As Range
Dim lastrow As Long
Set sht = Sheets("Sheet1")
lastrow = sht.Cells(Cells.Rows.Count, "G").End(xlUp).Row
Set MyRange = sht.Range("G1:G" & lastrow)
For Each c In MyRange
If c.Value = c.Offset(1).Value Then
If CopyRange Is Nothing Then
Set CopyRange = c.EntireRow
Else
Set CopyRange = Union(CopyRange, c.EntireRow)
End If
Else
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = c.Value
CopyRange.Resize(CopyRange.Rows.Count + 1).Copy _
Destination:=Sheets(c.Value).Range("A1")
thislastrow = Sheets(c.Value).Cells(Cells.Rows.Count, "G").End(xlUp).Row + 1
Range("B" & thislastrow).Formula = "=sum(B1:B" & thislastrow - 1 & ")"
Range("C" & thislastrow).Formula = "=sum(C1:C" & thislastrow - 1 & ")"
Sheets(c.Value).Columns("B:C").NumberFormat = "0.00"
sht.Activate
Set CopyRange = Nothing
End If
Next
End Sub
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.

 

[Mike H]

from the OP's original question

The last column (G) uses a staff code and is sorted in ascending order.

--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.

 

[Ryan H]

My mistake Mike. Thanks for the correction!

 

[malycom]

Mike & Ryan

Thank you both so much for your help.

I actually appear to be a genius at work, although as usual, that will be
short lived.

The worksheet does and shows exactly what it is supposed to.

Once again, thank you bnoth very much.

Regards

Malcolm Davidson

 

[Mike H]

Glad I could help and don't tell your work colleagues you never wrote the
code
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.

 

[malycom]

I'm to honest for that Mike. I always tell them where I get my help,
otherwise they think I'm just browsing the internet

Cheers

 

[malycom]

Hi Mike

I have just gone to run this for the first time as a needed report and I
have encountered an error.

It appears if there is only one record for a particular member of staff, ie,
Column G, the macro throws an error message and something about 'Object
Variable or With block variable not set'

When I click debug, the highlighted lines are the two lines that start with
CopyRange.Resize (CopyRange.Rows.Count + 1).Copy _
Destination:=Sheets(c.Value).Range("A1")

There is an arrow pointing to the second line which is the
Destination:=Sheets line.

Any way you can help with this problem?

Many thanks

Malcolm Davidson