Amendment to Existing Macro

[EmmaFairclough]

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??

[Anne Troy]

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]

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]

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