1. Computer problem? Tech Support Guy is completely free -- paid for by advertisers and donations. Click here to join today! If you're new to Tech Support Guy, we highly recommend that you visit our Guide for New Members.

Excel 2003 Header/Footer Macro

Discussion in 'Business Applications' started by DrewMcK, Oct 25, 2007.

Thread Status:
Not open for further replies.
Advertisement
  1. DrewMcK

    DrewMcK Thread Starter

    Joined:
    Jan 12, 2007
    Messages:
    18
    Recently our Office Suite was upgraded from 2000 to 2003.

    I had a macro (that you helped with) working well in the old version to upon save take a field from a worksheet 'lists' and write that field into the header and footer, and then update the last saved timestamp....

    Now it will not write to the header and footer at all, and will not update the time stamp for last saved.

    Here is the code from the worksheet 'lists':
    Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    If Target.Column = 1 Or 2 Then


    On Error Resume Next

    Application.DisplayAlerts = False
    'ActiveSheet.protect UserInterfaceOnly:=True
    Range("A2").Select
    Selection.TextToColumns Destination:=Worksheets("lists").Range("A3"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="*", FieldInfo:=Array(Array(1, 1), Array(2, 1))


    Application.DisplayAlerts = True
    End If

    End Sub
    (The 'lists' code as far as I know is only there to set the values to be used in the header, the workbook code is the one that takes those values and writes them to the header/footer)




    Here is the workbook code:

    Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, cancel As Boolean)



    Dim filename, rdims, name, fs As String
    Worksheets("lists").Range("A6").Value = fs

    Call SetSaveLoc
    If Worksheets("lists").Range("A2").Value = "" Then

    On Error Resume Next

    filename = InputBox("Please enter * title." & Chr(13) & "ie. (* Audit Worksheet)" & Chr(13) & Chr(13) & "First * (asterix) then document title.", "File Name")
    Worksheets("lists").Range("a2").Value = filename


    Sheets("lists").Select
    Range("A2").Select

    Application.DisplayAlerts = False
    'ActiveSheet.protect UserInterfaceOnly:=True
    Selection.TextToColumns Destination:=Worksheets("lists").Range("A3"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :="*", FieldInfo:=Array(Array(1, 1), Array(2, 1))
    Application.DisplayAlerts = True

    Call GetSaveLoc


    On Error GoTo 0

    Else


    End If





    For Each Sheet In ThisWorkbook.Sheets


    vSize = Sheets("lists").Range("A5").Value

    Sheet.PageSetup.LeftHeader = "&" & Chr(34) & "Arial,bold" & Chr(34) & "&" & vSize & "&IAS"
    Sheet.PageSetup.RightHeader = "&""Arial,bold" & Chr(34) & "&" & vSize & "&U" & Worksheets("lists").Range("B3").Value & Chr(10) & "&9&U&BDraft - For Discussion Purposes Only"

    Sheet.PageSetup.LeftFooter = "&""Arial,bold""&8Office of Economics" & Chr(13) & "RDIMS#" & " " & Worksheets("lists").Range("A3").Value & " - " & Worksheets("lists").Range("B3") & Chr(13) & "Last Edited: " & Format(Date, "dd-mm-yyyy") & " " & Time
    Sheet.PageSetup.CenterFooter = "&""Arial,bold""&8Page &P of &N"
    Sheet.PageSetup.RightFooter = "&""Arial,bold""&8Last Accessed / Printed :" & Chr(13) & "&D &T"
    Next Sheet

    ActiveWorkbook.Save
    End Sub

    'Save Place In WorkBook after going to another, for text to column
    Public Sub SaveLocation(ReturnToLoc As Boolean)

    Static WB As Workbook
    Static WS As Worksheet
    Static R As Range

    If ReturnToLoc = False Then
    Set WB = ActiveWorkbook
    Set WS = ActiveSheet
    Set R = Selection
    Else
    WB.Activate
    WS.Activate
    R.Select
    End If

    End Sub

    'To save the current location, call SetSaveLoc.

    Public Sub SetSaveLoc()
    SaveLocation (False)
    End Sub

    'To return to the saved location, call GetSaveLoc.

    Public Sub GetSaveLoc()
    SaveLocation (True)
    End Sub



    Thanks in advance...
     
  2. Zack Barresse

    Zack Barresse

    Joined:
    Jul 25, 2004
    Messages:
    5,452
    Hi there,

    Try stepping through your code (w/ F8) and seeing where your code goes awry. If you still can't get it, can you post a sample file?
     
  3. DrewMcK

    DrewMcK Thread Starter

    Joined:
    Jan 12, 2007
    Messages:
    18
    Sorry about that, I should have attached the file from the begining. When I step through SetSave it seems fine, but GetSave is giving me an object variable error. It seems as though they are defined but I don't know enough about it to say why this would happen with the version change.
     

    Attached Files:

  4. Zack Barresse

    Zack Barresse

    Joined:
    Jul 25, 2004
    Messages:
    5,452
    That is because (when True) the variables are not set, so there is an error. What do you want to do if you pass a True argument to this function? Do you want to specify the workbook/worksheet/range? And more importantly, why are you using the Get/Set save anyway?
     
  5. DrewMcK

    DrewMcK Thread Starter

    Joined:
    Jan 12, 2007
    Messages:
    18
    I am not sure about the True statement... I am using this macro because it was suggested somewhere down the line and it seemed to work with the old version of excel..

    I am not sure exactly what macro is needed, I just need it to write the value of cells (from lists worksheet) into the footer, and update the last time saved, everytime the workbook is saved.
     
  6. Zack Barresse

    Zack Barresse

    Joined:
    Jul 25, 2004
    Messages:
    5,452
    Some things to note...

    You use this piece of code...
    Code:
        If Target.Column = 1 Or 2 Then
    This is in fact not checking your 2 value at all. To check for both values (of columns) you need to do something like this ...
    Code:
        If Target.Column = 1 Or Target.Column = 2 Then
    Also, no need to select in that code...
    Code:
            Application.DisplayAlerts = False
            Range("A2").TextToColumns Destination:=Worksheets("lists").Range("A3"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:="*", _
                FieldInfo:=Array(Array(1, 1), Array(2, 1))
    Add, in one of your standard modules...
    Code:
    Sub ToggleEvents(blnState As Boolean)
    'Originally written by firefytr
        With Application
            .DisplayAlerts = blnState
            .EnableEvents = blnState
            .ScreenUpdating = blnState
            If blnState Then .CutCopyMode = False
            If blnState Then .StatusBar = False
        End With
    End Sub
    Change your ThisWorkbook module code to something like this...
    Code:
    Option Explicit
    
    Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, cancel As Boolean)
        Dim ws As Worksheet, wsLists As Worksheet, strFileName, varRDIMS, strName, lngFontSize As Long
        Call ToggleEvents(False)
        Set wsLists = ThisWorkbook.Sheets("lists")
        wsLists.Range("A6").Value = lngFontSize
        If wsLists.Range("A2").Value = "" Then
    StartInput:
            strFileName = InputBox("Please enter * title." & Chr(13) & "ie. (* Audit Worksheet)" & Chr(13) & Chr(13) & "First  * (asterix)  then document title.", "File Name")
            If strFileName = "" Then GoTo StartInput
            wsLists.Range("a2").Value = strFileName
            wsLists.Range("A2").TextToColumns Destination:=wsLists.Range("A3"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:="*", _
                FieldInfo:=Array(Array(1, 1), Array(2, 1))
            On Error GoTo 0
        End If
        For Each ws In ThisWorkbook.Worksheets
            lngFontSize = wsLists.Range("A5").Value
            ws.PageSetup.LeftHeader = "&" & Chr(34) & "Arial,bold" & Chr(34) & "&" & lngFontSize & "&IAS"
            ws.PageSetup.RightHeader = "&""Arial,bold" & Chr(34) & "&" & lngFontSize & "&U" & wsLists.Range("B3").Value & Chr(10) & "&9&U&BDraft - For Discussion Purposes Only"
            ws.PageSetup.LeftFooter = "&""Arial,bold""&8Office" & Chr(13) & "RDIMS#" & "  " & wsLists.Range("A3").Value & " - " & wsLists.Range("B3") & Chr(13) & "Last Edited: " & Format(Date, "dd-mm-yyyy") & " " & Time
            ws.PageSetup.CenterFooter = "&""Arial,bold""&8Page  &P of &N"
            ws.PageSetup.RightFooter = "&""Arial,bold""&8Last Accessed / Printed :" & Chr(13) & "&D &T"
        Next ws
    ExitWithSave:
        ActiveWorkbook.Save
    ExitWithoutSave:
        Call ToggleEvents(True)
    End Sub
    The above code should replace all of your ThisWorkbook module.
     
  7. DrewMcK

    DrewMcK Thread Starter

    Joined:
    Jan 12, 2007
    Messages:
    18
    I updated the sections of the 'list code' with what you had. I added the module code, and replaced the workbook code with what you had.

    When I save in the VB editor it works and updats the footer. But when I save in excel normally either by clicking, of Ctrl+S it does not update the footer at all?????

    This is actually what was happening to the original as well, when you saved it in VB editor it would update the footer, but not when you save in excel.
     
  8. Zack Barresse

    Zack Barresse

    Joined:
    Jul 25, 2004
    Messages:
    5,452
    Put a breakpoint on the first line of your save event code ...
    Code:
    Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, cancel As Boolean)
    .. just select it (put your cursor on it) and press F9. Notice the red dot to the left, you can click on that area to toggle on/off the breakpoints. Now go back to Excel and save like you did when the routine failed. Once the VBE pops up, step through with F8, see what happens and it if is the expected result(s).
     
  9. DrewMcK

    DrewMcK Thread Starter

    Joined:
    Jan 12, 2007
    Messages:
    18
    It steps through the entire process without problems, and looks like it should work as it steps throguh writing the footer, but still only when I save in VB editor does it update the footer. I don't get the difference in saving between vb editor and excel...
     
  10. bomb #21

    bomb #21

    Joined:
    Jul 1, 2005
    Messages:
    8,546
    Preferable to this is:

    If Target.Column > 2 Then Exit Sub

    in the preamble, provided you remember to remove the corresponding End If further down.

    HTH
     
  11. Zack Barresse

    Zack Barresse

    Joined:
    Jul 25, 2004
    Messages:
    5,452
    Drew, there is NO difference between ANY save except where you do a SaveAs you use an additional event first, if not cancelled you will still perform a Save. As bomb said, you may or may not have the activecell in column A.
     
  12. Sponsor

As Seen On
As Seen On...

Welcome to Tech Support Guy!

Are you looking for the solution to your computer problem? Join our site today to ask your question. This site is completely free -- paid for by advertisers and donations.

If you're not already familiar with forums, watch our Welcome Guide to get started.

Join over 733,556 other people just like you!

Loading...
Thread Status:
Not open for further replies.

Short URL to this thread: https://techguy.org/643271

  1. This site uses cookies to help personalise content, tailor your experience and to keep you logged in if you register.
    By continuing to use this site, you are consenting to our use of cookies.
    Dismiss Notice