Still celebrating National IT Professionals Day with 3 months of free Premium Membership. Use Code ITDAY17

x
?
Solved

VBA Excel - Code to Add Page Numbers

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

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

Question has a verified solution.

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

Enums (shorthand for ‘enumerations’) are not often used by programmers but they can be quite valuable when they are.  What are they? An Enum is just a type of variable like a string or an Integer, but in this case one that you create that contains…
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…
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…
Suggested Courses

670 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