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

Question

我在 Windows 中使用 Excel 365，并尝试在单元格内容更改时将某些单元格的内容复制到工作表页眉（或页脚）。例如，我正在创建一系列数据表，在第一页我有一个单元格，用户在其中键入客户使用的采购订单 (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

标签： excelheaderfooter