Solved

VBA Excel - Code to Add Page Numbers

Posted on 2009-04-05
2
8,071 Views
Last Modified: 2013-11-25
I wrote a macro that formats pasted data and then adds page numbers to the footer. In the original workbook that I created the macro it works perfectly, adds the pages numbers no problem. I then moved the macro to my personal macro book so that I can use it in what ever work book I have open. Everything works, except the add page number Function. I even went back into the original work book, tried it again there, works no problem. Copy and pasted the code from the macro into the personal macro and still the page number won't work.

What is my mal-function
Function SelectAll()

Cells.Select

End Function
 

Function SortAlpha()
 

    Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _

        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _

        DataOption1:=xlSortNormal

        

End Function
 

Function AddPageNum()
 

    Dim sPageNum As String

    

    Const sPAGE As String = "&P"

    Const sPAGES As String = "&N"

    

    sPageNum = sPAGE & " of " & sPAGES

 

    With Sheet1.PageSetup

        .CenterFooter = sPageNum

    End With

    

End Function
 

Function DeleteTop()
 

Cells.Range("a1:a4").Select

Selection.Delete
 

End Function
 

Function GoHome()

Cells.Range("a1").Select

End Function
 

Function DelHeadquarter()

    

    Dim rng1 As Range, rng2 As Range, cel As Range

    Dim FirstAddress As String

    Dim AppCalc As Long

 

    Set rng1 = ActiveSheet.UsedRange

 

    With Application

        AppCalc = .Calculation

        .ScreenUpdating = False

        .Calculation = xlCalculationManual

    End With

 

    'match string to entire cell

    'Set cel = rng1.Find("XXXX", , xlValues, xlWhole, xlByRows)

    ' match string to part of cell

    Set cel = rng1.Find("{{headquarter", , xlValues, xlPart, xlByRows)

    If Not cel Is Nothing Then

        Set rng2 = cel

        FirstAddress = cel.Address

        Do

            Set cel = rng1.FindNext(cel)

            'test to avoid ending up with multiple selections in one row to delete

            If Intersect(cel.EntireRow, rng2) Is Nothing Then Set rng2 = Union(rng2, cel)

        Loop While FirstAddress <> cel.Address

    End If

 

    If Not rng2 Is Nothing Then rng2.EntireRow.Delete

 

    With Application

        .ScreenUpdating = True

        .Calculation = AppCalc

    End With

 

End Function
 

Function DelLTM()

    

    Dim rng1 As Range, rng2 As Range, cel As Range

    Dim FirstAddress As String

    Dim AppCalc As Long

 

    Set rng1 = ActiveSheet.UsedRange

 

    With Application

        AppCalc = .Calculation

        .ScreenUpdating = False

        .Calculation = xlCalculationManual

    End With

 

    'match string to entire cell

    'Set cel = rng1.Find("XXXX", , xlValues, xlWhole, xlByRows)

    ' match string to part of cell

    Set cel = rng1.Find("{{LTM Total", , xlValues, xlPart, xlByRows)

    If Not cel Is Nothing Then

        Set rng2 = cel

        FirstAddress = cel.Address

        Do

            Set cel = rng1.FindNext(cel)

            'test to avoid ending up with multiple selections in one row to delete

            If Intersect(cel.EntireRow, rng2) Is Nothing Then Set rng2 = Union(rng2, cel)

        Loop While FirstAddress <> cel.Address

    End If

 

    If Not rng2 Is Nothing Then rng2.EntireRow.Delete

 

    With Application

        .ScreenUpdating = True

        .Calculation = AppCalc

    End With

 

End Function
 

Function DelCurrentInv()

    

    Dim rng1 As Range, rng2 As Range, cel As Range

    Dim FirstAddress As String

    Dim AppCalc As Long

 

    Set rng1 = ActiveSheet.UsedRange

 

    With Application

        AppCalc = .Calculation

        .ScreenUpdating = False

        .Calculation = xlCalculationManual

    End With

 

    'match string to entire cell

    'Set cel = rng1.Find("XXXX", , xlValues, xlWhole, xlByRows)

    ' match string to part of cell

    Set cel = rng1.Find("Current Investment |", , xlValues, xlPart, xlByRows)

    If Not cel Is Nothing Then

        Set rng2 = cel

        FirstAddress = cel.Address

        Do

            Set cel = rng1.FindNext(cel)

            'test to avoid ending up with multiple selections in one row to delete

            If Intersect(cel.EntireRow, rng2) Is Nothing Then Set rng2 = Union(rng2, cel)

        Loop While FirstAddress <> cel.Address

    End If

 

    If Not rng2 Is Nothing Then rng2.EntireRow.Delete

 

    With Application

        .ScreenUpdating = True

        .Calculation = AppCalc

    End With

 

End Function
 

Function DelCurrentSub()

    

    Dim rng1 As Range, rng2 As Range, cel As Range

    Dim FirstAddress As String

    Dim AppCalc As Long

 

    Set rng1 = ActiveSheet.UsedRange

 

    With Application

        AppCalc = .Calculation

        .ScreenUpdating = False

        .Calculation = xlCalculationManual

    End With

 

    'match string to entire cell

    'Set cel = rng1.Find("XXXX", , xlValues, xlWhole, xlByRows)

    ' match string to part of cell

    Set cel = rng1.Find("Current subsidiary", , xlValues, xlPart, xlByRows)

    If Not cel Is Nothing Then

        Set rng2 = cel

        FirstAddress = cel.Address

        Do

            Set cel = rng1.FindNext(cel)

            'test to avoid ending up with multiple selections in one row to delete

            If Intersect(cel.EntireRow, rng2) Is Nothing Then Set rng2 = Union(rng2, cel)

        Loop While FirstAddress <> cel.Address

    End If

 

    If Not rng2 Is Nothing Then rng2.EntireRow.Delete

 

    With Application

        .ScreenUpdating = True

        .Calculation = AppCalc

    End With

 

End Function
 

Function DelMergedEnt()

    

    Dim rng1 As Range, rng2 As Range, cel As Range

    Dim FirstAddress As String

    Dim AppCalc As Long

 

    Set rng1 = ActiveSheet.UsedRange

 

    With Application

        AppCalc = .Calculation

        .ScreenUpdating = False

        .Calculation = xlCalculationManual

    End With

 

    'match string to entire cell

    'Set cel = rng1.Find("XXXX", , xlValues, xlWhole, xlByRows)

    ' match string to part of cell

    Set cel = rng1.Find("Merged Entity", , xlValues, xlPart, xlByRows)

    If Not cel Is Nothing Then

        Set rng2 = cel

        FirstAddress = cel.Address

        Do

            Set cel = rng1.FindNext(cel)

            'test to avoid ending up with multiple selections in one row to delete

            If Intersect(cel.EntireRow, rng2) Is Nothing Then Set rng2 = Union(rng2, cel)

        Loop While FirstAddress <> cel.Address

    End If

 

    If Not rng2 Is Nothing Then rng2.EntireRow.Delete

 

    With Application

        .ScreenUpdating = True

        .Calculation = AppCalc

    End With

 

End Function
 

Function DelParentComp()

    

    Dim rng1 As Range, rng2 As Range, cel As Range

    Dim FirstAddress As String

    Dim AppCalc As Long

 

    Set rng1 = ActiveSheet.UsedRange

 

    With Application

        AppCalc = .Calculation

        .ScreenUpdating = False

        .Calculation = xlCalculationManual

    End With

 

    'match string to entire cell

    'Set cel = rng1.Find("XXXX", , xlValues, xlWhole, xlByRows)

    ' match string to part of cell

    Set cel = rng1.Find("Parent Company", , xlValues, xlPart, xlByRows)

    If Not cel Is Nothing Then

        Set rng2 = cel

        FirstAddress = cel.Address

        Do

            Set cel = rng1.FindNext(cel)

            'test to avoid ending up with multiple selections in one row to delete

            If Intersect(cel.EntireRow, rng2) Is Nothing Then Set rng2 = Union(rng2, cel)

        Loop While FirstAddress <> cel.Address

    End If

 

    If Not rng2 Is Nothing Then rng2.EntireRow.Delete

 

    With Application

        .ScreenUpdating = True

        .Calculation = AppCalc

    End With

 

End Function
 

Function DelDenotes()

    

    Dim rng1 As Range, rng2 As Range, cel As Range

    Dim FirstAddress As String

    Dim AppCalc As Long

 

    Set rng1 = ActiveSheet.UsedRange

 

    With Application

        AppCalc = .Calculation

        .ScreenUpdating = False

        .Calculation = xlCalculationManual

    End With

 

    'match string to entire cell

    'Set cel = rng1.Find("XXXX", , xlValues, xlWhole, xlByRows)

    ' match string to part of cell

    Set cel = rng1.Find("*denotes", , xlValues, xlPart, xlByRows)

    If Not cel Is Nothing Then

        Set rng2 = cel

        FirstAddress = cel.Address

        Do

            Set cel = rng1.FindNext(cel)

            'test to avoid ending up with multiple selections in one row to delete

            If Intersect(cel.EntireRow, rng2) Is Nothing Then Set rng2 = Union(rng2, cel)

        Loop While FirstAddress <> cel.Address

    End If

 

    If Not rng2 Is Nothing Then rng2.EntireRow.Delete

 

    With Application

        .ScreenUpdating = True

        .Calculation = AppCalc

    End With

 

End Function
 
 
 

Function ReplaceArrow1()

    Dim c As Range

    For Each c In ActiveSheet.UsedRange

        c = Replace(c, ChrW(&H2192) & " ", "")

    Next

End Function
 

Function ReplaceSpaces()

    Dim c As Range

    For Each c In ActiveSheet.UsedRange

        c = Replace(c, "       ", "")

    Next

End Function
 

Function MoveText()
 

Dim strTest As String

strTest = ChrW(&H2192)

Cells.Range("d2").Value = strTest
 

End Function
 

Function ChangeFont()
 

Cells.Select

Selection.Font.Color = RGB(0, 0, 0)
 

End Function
 
 

Sub Logan_TreeMacro()

Call DeleteTop

Call SelectAll

Call SortAlpha

Call AddPageNum

Call DelHeadquarter

Call DelLTM

Call DelCurrentInv

Call DelCurrentSub

Call DelMergedEnt

Call DelParentComp

Call DelDenotes

Call ReplaceSpaces

Call ReplaceArrow1

Call SelectAll

Call ChangeFont

Call SortAlpha

Call GoHome

End Sub

Open in new window

0
Comment
Question by:ThePATMAN26
2 Comments
 
LVL 5

Accepted Solution

by:
QuintainT earned 250 total points
ID: 24072406
I'm no Excel expert so this may be nonsense, but I notice that your AddPageNum function is the only function that refers to a specific sheet. All the other refer to the active sheet. Possibly refering to sheet1 in this macro is referencing the original sheet and not the sheet in the current workbook. You might need to qualify sheet1 by adding the workbook name in front. Or possibly by refering to it by index.
0
 
LVL 92

Assisted Solution

by:Patrick Matthews
Patrick Matthews earned 250 total points
ID: 24072487
Hello ThePATMAN26,

QuintainT is entirely correct: the function is failing because it is referring to a specific sheet in your personal
macro workbook, and not to the current ActiveSheet.  Change:

    With Sheet1.PageSetup

to:

    With ActiveSheet.PageSetup

and you should be good to go.

Regards,

Patrick
0

Featured Post

Maximize Your Threat Intelligence Reporting

Reporting is one of the most important and least talked about aspects of a world-class threat intelligence program. Here’s how to do it right.

Join & Write a Comment

Suggested Solutions

Article by: Martin
Here are a few simple, working, games that you can use as-is or as the basis for your own games. Tic-Tac-Toe This is one of the simplest of all games.   The game allows for a choice of who goes first and keeps track of the number of wins for…
This article is the result of a quest to better understand Task Scheduler 2.0 and all the newer objects available in vbscript in this version over  the limited options we had scripting in Task Scheduler 1.0.  As I started my journey of knowledge I f…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

758 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

22 Experts available now in Live!

Get 1:1 Help Now