Help with this macro script on single results.

[malycom]

Hi

I put a request out a few days ago and I am attaching the macro script as
well so you can see where I am up to.

The problem is, if there is only one result returned for a particular staff
member, the script falls with a variable object error.

If there is more than 1 record, the script works fine. It just falls where
a single record is returned.

I am attaching the original message I sent as well as the script. PLease
note that Mike, the guy that helped me immensley witht his, has also doen a
few other things like auto summing which you will see in the script but not
in my original message.

Original message and help
================================================

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



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

==================================================

Any help with this is greatly appreciated.

Thanks in advance

Malcolm

 

[Sam Wilson]

Hi,

Change:

Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = c.Value

to this:

Set CopyRange = Union(CopyRange, c.EntireRow)
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = c.Value

What you currently have checks if the value in the cell is the same as the
one below it. If it is it adds it to copy range, if it's not then it pastes
copyrange into the new sheet - but copy range will be nothing as you haven't
set it.

Sam

 

[malycom]

Hi Sam

Thanks for your help but this now causes a different error.

What happens is the works sheets are created for the individual staff
members as it should, but the last row of each worksheet contains the first
record for the next staff member that should be in a new worksheet.

Also, when it hits a single record again, that record does appear as the
last record in the previous members worksheet but then the system stops again
with an error message.

In debug mode, the fist line that I changed to match your advice is yellow
and if I hover my mouse over the Union(CopyRange, c.EntireRow), a hint
message of CopyRange = Nothing is shown. Not sure if that's supposed to be
what it says or not.

Any other ideas?

Thanks for your help though.

Malcolm

 

[Jacob Skaria]

Try the below

Sub stantial()
Dim ws As Worksheet, wsTemp As Worksheet
Dim lngRow As Long, lngStartRow As Long, lngTargetRow As Long

Set ws = Sheets("Sheet1")
lngStartRow = 2
For lngRow = lngStartRow + 1 To ws.Cells(Rows.Count, "G").End(xlUp).Row + 1
If ws.Range("G" & lngRow) <> ws.Range("G" & lngRow - 1) Then
On Error Resume Next
Set wsTemp = Sheets(CStr(ws.Range("G" & lngRow - 1)))
On Error GoTo 0
If wsTemp Is Nothing Then
Set wsTemp = Worksheets.Add(After:=ws)
wsTemp.Name = ws.Range("G" & lngRow - 1)
ws.Rows(1).Copy wsTemp.Range("A1")
End If
lngTargetRow = wsTemp.Cells(Rows.Count, "G").End(xlUp).Row
ws.Range("A" & lngStartRow & ":G" & lngRow - 1).Copy _
wsTemp.Range("A" & lngTargetRow + 1)
Set wsTemp = Nothing
lngStartRow = lngRow
End If
Next

End Sub

 

[malycom]

Hi Jacob

Very close but now the auto sum of columns B & C has dissapeared from each
of the worksheets. Admitedly, it wasn't in my initial request but it is
something that I asked another person to add.

Is there any way to get this auto summing back in please?

Thanks for your help - I don't know how you guys do it.

Malcolm

 

[Jacob Skaria]

I missed that..

Sub stantial()
Dim ws As Worksheet, wsTemp As Worksheet
Dim lngRow As Long, lngStartRow As Long, lngTargetRow As Long

Set ws = Sheets("Sheet1")
lngStartRow = 2
For lngRow = lngStartRow + 1 To ws.Cells(Rows.Count, "G").End(xlUp).Row + 1
If ws.Range("G" & lngRow) <> ws.Range("G" & lngRow - 1) Then
On Error Resume Next
Set wsTemp = Sheets(CStr(ws.Range("G" & lngRow - 1)))
On Error GoTo 0
If wsTemp Is Nothing Then
Set wsTemp = Worksheets.Add(After:=ws)
wsTemp.Name = ws.Range("G" & lngRow - 1)
ws.Rows(1).Copy wsTemp.Range("A1")
End If
lngTargetRow = wsTemp.Cells(Rows.Count, "G").End(xlUp).Row
ws.Range("A" & lngStartRow & ":G" & lngRow - 1).Copy _
wsTemp.Range("A" & lngTargetRow + 1)
lngTargetRow = wsTemp.Cells(Rows.Count, "G").End(xlUp).Row
wsTemp.Range("B" & lngTargetRow + 1).Formula = _
"=SUM(B1:B" & lngTargetRow & ")"
wsTemp.Range("C" & lngTargetRow + 1).Formula = _
"=SUM(C1:C" & lngTargetRow & ")"
Set wsTemp = Nothing
lngStartRow = lngRow
End If
Next

End Sub

 

[malycom]

Thank you so much

Everything working fine now.

Appreciate the help from everybody.

Malcolm