'==============================================================================
'- 2 MACROS TO EDIT WORKSHEET HEADER & FOOTER
'- 1. 'READ_HEADER_FOOTER' reads from the active sheet (makes a new worksheet)
'- 2. 'WRITE_HEADER_FOOTER' writes amended data back to the original
'- Handles multi lines.
'- Brian Baulsom July 2007 using Excel 2000
'==============================================================================
Option Explicit
Dim WS As Worksheet
Dim ToRow As Long
Dim ToCol As Integer
Dim OriginalSheetName As String
Dim HeadFootStrings(6)
Dim s, c, c1, c2, L
'==============================================================================
'- 1. READ MACRO -
'- Run macro from the sheet to be checked - *EITHER* makes a new sheet
'- *OR* updates an existing "Read" sheet (looks for $A$3 = "Left Header")
'==============================================================================
Sub READ_HEADER_FOOTER()
Dim LastCell As String
Dim LastRow As Long
Dim LastCol As Integer
Dim MyStr As String
'-------------------------------------------------------------------
'- check active sheet for new or existing data
If ActiveSheet.Range("A3").Value = "Left Header" Then
'- UPDATE EXISTING SHEET
OriginalSheetName = ActiveSheet.Range("A1").Value
'------------------------------
LastRow = ActiveSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows).Row
'------------------------------
LastCol = ActiveSheet.Cells.Find(What:="*", SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns).Column
'------------------------------
LastCell = ActiveSheet.Cells(LastRow, LastCol).Address
Range("A4:" & LastCell).ClearContents
Else
'-------------------------------------------------------------------
'- MAKE NEW WORKSHEET
OriginalSheetName = ActiveSheet.Name
Set WS = Worksheets.Add
WS.Name = "HF - " & OriginalSheetName
'-----------------------------------------------------------------
'- original sheet name
With WS.Range("A1")
.Value = OriginalSheetName
.Font.Bold = True
.Font.Size = 14
.RowHeight = 30
End With
'-----------------------------------------------------------------
'- column headers
With WS.Range("A3:F3")
.ColumnWidth = 28
.Value = _
Array("Left Header", "Centre Header", "Right Header", "Left Footer", "Centre Footer", "Right Footer")
.Interior.ColorIndex = 34
.Font.Bold = True
End With
'------------------------------------------------------------------
'- add WRITE button
ActiveSheet.Buttons.Add(200, 5, 150, 25).Select
Selection.OnAction = "WRITE_HEADER_FOOTER"
With Selection.Characters
.Text = "WRITE HEADERS & FOOTERS"
.Font.Size = 10
End With
End If
'================================================================
'- GET HEADER & FOOTER DATA
'================================================================
With Worksheets(OriginalSheetName).PageSetup
HeadFootStrings(1) = .LeftHeader
HeadFootStrings(2) = .CenterHeader
HeadFootStrings(3) = .RightHeader
HeadFootStrings(4) = .LeftFooter
HeadFootStrings(5) = .CenterFooter
HeadFootStrings(6) = .RightFooter
End With
'-------------------------------------------------------------
'- parse strings
ToCol = 1
For s = 1 To 6
ToRow = 4
MyStr = HeadFootStrings(s)
c1 = 1
L = Len(MyStr)
If L = 0 Then Exit Sub
'--------------------------------------------------------------
'- parse string
For c = 1 To L
'- check for end of line character chr(10)
If Asc(Mid(MyStr, c, 1)) = 10 Then
WS.Cells(ToRow, ToCol).Value = Mid(MyStr, c1, c - c1)
ToRow = ToRow + 1
c1 = c + 1
End If
Next
If c1 < L Then
WS.Cells(ToRow, ToCol).Value = Mid(MyStr, c1, c - c1)
End If
'-------------------------------------------------------------
'- next column
ToCol = ToCol + 1
Next
'-----------------------------------------------------------------
MsgBox ("Done")
End Sub
'===========END OF READ ROUTINE ======================================
'======================================================================
'- 2. WRITE MACRO
'- Writes amended data from the "Read" sheet to the original worksheet
'======================================================================
Sub WRITE_HEADER_FOOTER()
Dim LastRow, MyStr As String
'-----------------------------------------------------------------
'- sheet data to HeadFootStrings
Set WS = ActiveSheet
For ToCol = 1 To 6
LastRow = WS.Cells(65536, ToCol).End(xlUp).Row
MyStr = ""
For ToRow = 4 To LastRow
MyStr = MyStr & WS.Cells(ToRow, ToCol).Value
If ToRow < LastRow Then MyStr = MyStr & Chr(10)
Next
HeadFootStrings(ToCol) = MyStr
Next
'----------------------------------------------------------------
'- update original worksheet
OriginalSheetName = WS.Range("A1").Value
With Worksheets(OriginalSheetName).PageSetup
.LeftHeader = HeadFootStrings(1)
.CenterHeader = HeadFootStrings(2)
.RightHeader = HeadFootStrings(3)
.LeftFooter = HeadFootStrings(4)
.CenterFooter = HeadFootStrings(5)
.RightFooter = HeadFootStrings(6)
End With
'----------------------------------------------------------------
MsgBox ("Done")
End Sub
'============= END OF WRITE ROUTINE ====================================
