Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

VBA Excel - Code to Add Page Numbers

Posted on 2009-04-05
2
Medium Priority
?
8,442 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 1000 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 93

Assisted Solution

by:Patrick Matthews
Patrick Matthews earned 1000 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

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

Question has a verified solution.

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

Deploying a Microsoft Access application in a Citrix environment is not difficult but takes a few steps. However, Citrix system people are often of little help, as they typically know next to nothing about Access. The script provided here will take …
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
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…
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…

926 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