Solved

VBA Excel - Code to Add Page Numbers

Posted on 2009-04-05
2
8,253 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
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

[Live Webinar] The Cloud Skills Gap

As Cloud technologies come of age, business leaders grapple with the impact it has on their team's skills and the gap associated with the use of a cloud platform.

Join experts from 451 Research and Concerto Cloud Services on July 27th where we will examine fact and fiction.

Question has a verified solution.

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

Have you ever wanted to restrict the users input in a textbox to numbers, and while doing that make sure that they can't 'cheat' by pasting in non-numeric text? Of course you can do that with code you write yourself but it's tedious and error-prone …
If you need to start windows update installation remotely or as a scheduled task you will find this very helpful.
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 process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
Suggested Courses
Course of the Month8 days, 17 hours left to enroll

617 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