Solved

VBA Excel - Code to Add Page Numbers

Posted on 2009-04-05
2
8,178 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

Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

You can of course define an array to hold data that is of a particular type like an array of Strings to hold customer names or an array of Doubles to hold customer sales, but what do you do if you want to coordinate that data? This article describes…
Calculating holidays and working days is a function that is often needed yet it is not one found within the Framework. This article presents one approach to building a working-day calculator for use in .NET.
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

820 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