单元格内容更改时，将单元格内容放入Excel工作表页眉或页脚

Question

我正在Windows中使用Excel 365，并且试图将某些单元格的内容在单元格内容更改时复制到工作表页眉（或页脚）中。例如，我正在创建一系列数据表，并且在第一个页面上有一个单元格，用户可以在其中键入客户使用的采购订单（PO）。我希望用户输入一次PO编号，然后将PO编号放置在所有后续页脚中。当打印数据表堆栈时，PO（和其他键信息）将出现在所有页面上。 我知道Excel并非自然而然地做到这一点，而且我已经找到了一些相当丑陋的宏和VB代码来通过Google以编程方式进行此操作，但我无法使其工作。所以...我希望有一些简单的魔术。

Private HeaderSave() As Variant
Private HeaderChanged() As Variant

Public Sub SaveAndSetHeaders()

Dim Index As Long

' Save and set header and footer text Application.ScreenUpdating = False
  ReDim HeaderSave(1 To ThisWorkbook.Sheets.Count) ReDim HeaderChanged(1 To 
  ThisWorkbook.Sheets.Count, 0 To 5)'

For Index = 1 To ThisWorkbook.Sheets.Count
      With ThisWorkbook.Sheets(Index).PageSetup
      HeaderSave(Index) = Array(.LeftHeader, .CenterHeader, .RightHeader, 
      .LeftFooter, .CenterFooter, .RightFooter)

   If InStr(HeaderSave(Index)(0), "^[Cell:") > 0 Then
        .LeftHeader = SubstituteCellValues(ThisWorkbook.Sheets(Index),
        HeaderSave(Index)(0))
        HeaderChanged(Index, 0) = True
   End If

   If InStr(HeaderSave(Index)(1), "^[Cell:") > 0 Then
        .CenterHeader = SubstituteCellValues(ThisWorkbook.Sheets(Index), 
        HeaderSave(Index)(1))
        HeaderChanged(Index, 1) = True
   End If

   If InStr(HeaderSave(Index)(2), "^[Cell:") > 0 Then
        .RightHeader = SubstituteCellValues(ThisWorkbook.Sheets(Index), 
         HeaderSave(Index)(2))
        HeaderChanged(Index, 2) = True
   End If

  If InStr(HeaderSave(Index)(3), "^[Cell:") > 0 Then
        .LeftFooter = SubstituteCellValues(ThisWorkbook.Sheets(Index), 
        HeaderSave(Index)(3))
        HeaderChanged(Index, 3) = True
  End If

  If InStr(HeaderSave(Index)(4), "^[Cell:") > 0 Then
        .CenterFooter = SubstituteCellValues(ThisWorkbook.Sheets(Index), 
        HeaderSave(Index)(4))
        HeaderChanged(Index, 4) = True
  End If

  If InStr(HeaderSave(Index)(5), "^[Cell:") > 0 Then
        .RightFooter = SubstituteCellValues(ThisWorkbook.Sheets(Index), 
        HeaderSave(Index)(5))
        HeaderChanged(Index, 5) = True
 End If
End With

Next Index
   Application.ScreenUpdating = True

End Sub

Public Sub RestoreHeaders()

Dim Index As Long

   ' Restore header and footer text'

   Application.ScreenUpdating = False

For Index = 1 To ThisWorkbook.Sheets.Count
   With ThisWorkbook.Sheets(Index).PageSetup
      If HeaderChanged(Index, 0) Then .LeftHeader = HeaderSave(Index)(0)
      If HeaderChanged(Index, 1) Then .CenterHeader = HeaderSave(Index)(1)
      If HeaderChanged(Index, 2) Then .RightHeader = HeaderSave(Index)(2)
      If HeaderChanged(Index, 3) Then .LeftFooter = HeaderSave(Index)(3)
      If HeaderChanged(Index, 4) Then .CenterFooter = HeaderSave(Index)(4)
      If HeaderChanged(Index, 5) Then .RightFooter = HeaderSave(Index)(5)
  End With
 Next Index

  Application.ScreenUpdating = True

End Sub

Private Function SubstituteCellValues( _
    ByVal FocusSheet As Worksheet, _
    ByVal Text As String _
    ) As String

' Look for the text "^[Cell:A1]" and replace it with the cell's value. The 
  cell reference can be any valid cell reference with or without a sheet 
  name. If no sheet name is included the sheet for which the header or 
  footer text is defined is assumed.'

Dim StartPos As Long
Dim EndPos As Long
Dim FindText As String
Dim ReplaceText As String
Dim CellReference As String

Do
  StartPos = InStr(Text, "^[Cell:")

  If StartPos > 0 Then
     EndPos = InStr(StartPos, Text, "]") 
         If EndPos = 0 Then Exit Do
             FindText = Mid(Text, StartPos, EndPos - StartPos + 1)
             CellReference = Mid(FindText, 8, Len(FindText) - 8)
         If InStr(CellReference, "!") = 0 Then
             CellReference = "'" & FocusSheet.Name & "'!" & CellReference
         End If
     On Error Resume Next
     ReplaceText = Range(CellReference).Value
     On Error GoTo 0
     Text = Replace(Text, FindText, ReplaceText)
  Else
     Exit Do
  End If
Loop

SubstituteCellValues = Text

End Function

Private Sub Workbook_BeforePrint(Cancel As Boolean)
   SaveAndSetHeaders
   Application.OnTime Now, "ThisWorkbook.Workbook_AfterPrint"
End Sub

Private Sub Workbook_AfterPrint() 
   RestoreHeaders
End Sub