PDA

View Full Version : Solved: Amendment to Existing Macro



EmmaFairclough
06-24-2004, 07:30 AM
I've got part of a macro completed thanks to theofficeexperts but then received a pm to visit here and thought I'd come and say hello to you lovely people!!

The macro looks like this
Sub CreateSummary()

Application.ScreenUpdating = False
Dim ws As Worksheet
Dim f As String, x As String
f = "SUMMARY"
For Each ws In ThisWorkbook.Worksheets
ws.Activate
If ActiveSheet.Name = f Then GoTo circumv1
x = ActiveSheet.Name
If Range("J65536").End(xlUp).Row = 1 Then GoTo circumv1
Range("A2", Range("J65536").End(xlUp)).Copy
With Sheets(f)
.Range("A65536").End(xlUp).Offset(1).Value = x
.Range("A65536").End(xlUp).Offset(1).PasteSpecial (xlPasteAll)
End With
circumv1:
Next ws
Sheets(f).Select
Application.ScreenUpdating = True

End Sub

It works really well except that I want it to copy over one set of headings and make the page names bold.

Any ideas??

:cool:

Anne Troy
06-24-2004, 08:18 AM
Hi, Emma! Welcome!
Zack is away until Sunday...

Anyway, see the link in my signature about using VBA tags here in our forum. It's very cool. :)

Then, you can edit your post above to *fix* it.

TonyJollans
06-24-2004, 08:53 AM
Hi Emma,

Welcome to VBAX!

I'm guessing that your headings are in Row 1, columns A to J, and the same on all sheets. I've made some changes to the code, and added comments. It should now do what you ask.

Sub CreateSummary()
Application.ScreenUpdating = False
Dim ws As Worksheet
Dim f As String, x As String
f = "SUMMARY"

' New variable declarations
Dim SingleCell As Range
Dim HeadingsCopied As Boolean

For Each ws In ThisWorkbook.Worksheets

' No need to Activate the Sheet - it's jusrt a performance drain
' ws.Activate

' Use ws instead of ActiveSheet as we no longer Activate
If ws.Name = f Then GoTo circumv1
x = ws.Name

' Range defaults to ActiveSheet ...
' ... as we don't have it any more, use ws explicitly
With ws
If .Range("J65536").End(xlUp).Row = 1 Then GoTo circumv1

' Copy Headings - once only
If Not HeadingsCopied Then
.Range("A1:J1").Copy Sheets(f).Range("A1:J1")
HeadingsCopied = True
End If

' Set reference to first target cell - and use it
Set SingleCell = Sheets(f).Range("A65536").End(xlUp).Offset(1)

With SingleCell
.Value = x

' Make it bold
.Font.Bold = True

' Note copy here - just before paste
ws.Range("A2", ws.Range("J65536").End(xlUp)).Copy
.Offset(1).PasteSpecial (xlPasteAll)
End With

End With

circumv1:
Next ws

Sheets(f).Select
Application.ScreenUpdating = True

' Tidy Up
Set SingleCell = Nothing
Set ws = Nothing
End Sub

EmmaFairclough
06-25-2004, 05:38 AM
You are an absolute star! Thanks a million for that one. I'm not sure exactly what it all means yet but I'm sure I'll get there.

;)

Thanks again