在保存事件时创建 header 和页脚。检查 header 或页脚是否存在

Question

我创建了一个 macro-template (workbook.xltm) 并将其移动到 C:\Users\USER\AppData\Roaming\Microsoft\Excel\XLSTART。所以这个文件作为默认工作簿打开。该工作簿包含一个小脚本，当用户单击保存按钮时会执行该脚本。该脚本将 header 和页脚添加到所有 sheet 中。

我的问题是工作流程，因为当打开新文件时，用户往往会通过更改公司名称等方式来更改 header。不幸的是，此时文件尚未保存，因此点击保存按钮，header 将被脚本中的默认公司名称覆盖。

最好有一个条件来检查 header 和页脚是否已经存在。那将是用户第一次保存文件的时间点。这将避免 header 被脚本的默认 header 文本覆盖的情况。
除此之外，如果第一个 sheet（左起）的 header 和页脚用于（复制到）所有新创建的 sheet s（如果用户创建它们）。现在，如果用户创建一个新的 sheet 并点击保存按钮，新 sheet 中的 header/footer 看起来像脚本中的默认 header/footer。

脚本：

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    ActiveSheet.PageSetup.LeftHeader = "Company: Company Ltd." & Chr(10) & "Cutoff date: 31.12.20XX"
    ActiveSheet.PageSetup.LeftFooter = "Filename: &F" & Chr(10) & "Sheet: &A"
    ActiveSheet.PageSetup.CenterFooter = "Page &P of &N"
    ActiveSheet.PageSetup.TopMargin = Application.CentimetersToPoints(3.91)
    ActiveSheet.PageSetup.HeaderMargin = Application.CentimetersToPoints(1.91)
End Sub

Answer 1

我会将默认模板的左侧、中间和右侧 header 留空，并在保存时检查它。然后我会保存这些值并将它们复制到所有其他工作表。如果您有很多工作表，则值得暂时关闭打印通信。

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim ShActive as Worksheet, sh As Worksheet
    Dim sLH as String, sCH as String, sRH As String

    Application.Printcommunication = False
    Set shActive = ActiveSheet
    With Activesheet.PageSetup
         sLH = .LeftHeader
         sCH = .CenterHeader
         ...
         If lenb(sLH) = 0 And lenb(sCH) = 0 And lenb(sRH) = 0 Then ' all empty = set defaults
              sLH = "Company: Company Ltd." & Chr(10) & "Cutoff date: 31.12.20XX"
              ....
         End If
    End With

    For Each sh in ActiveWorkBook.Sheets
        With sh.PageSetup
            .LeftHeader = sLH
            ...
        End With
    Next
    shActive.Activate ' just for sure
    Application.Printcommunication = True

Answer 2

感谢您的投入和支持。我设法创建了一个 template-file 和一个名为 "Template" 的 sheet，它几乎已经包含了用户创建的所有 sheet 所需的几乎所有信息。我现在需要 re-add Workbook_BeforeSave 事件，因为我当前的脚本无法处理用户将 sheet 从另一个工作簿复制到此 sheet 的事件。所以复制的 sheet 缺少页眉和页脚。

为所有新创建的 sheet 添加页眉和页脚的当前脚本：
它将sheet "Template"的信息复制到新创建的sheet中。所以 "Template" sheet 是一个要求。

Private Sub Workbook_NewSheet(ByVal Sh As Object)
    Application.ScreenUpdating = False
    With Sheets("Template").PageSetup
        strHeadLeft = .LeftHeader
        strHeadCenter = .CenterHeader
        strHeadRight = .RightHeader
        'strFootLeft = .LeftFooter
        'strFootCenter = .CenterFooter
        'strFootRight = .RightFooter
        bGotHeaders = True
    End With
    If bGotHeaders Then
        With ActiveSheet.PageSetup
            .LeftHeader = strHeadLeft
            .CenterHeader = strHeadCenter

            If IsEmpty(strHeadRight) Then
                strHeadRight = _
                 "&10Ref: &B&10&KFF0000 XXX-XXX" & _
                  Chr(10) & _
                  "&B&K000000File date created: " & _
                  Format(Date, "dd.mm.yyyy") & " " & Time & Chr(10) & _
                  "User: &B" & Application.UserName
            Else
                strHeadRight = strHeadRight & _
                 Chr(10) & _
                 "&B&K000000File date created: " & _
                 Format(Date, "dd.mm.yyyy") & " " & Time & Chr(10) & _
                 "User: &B" & Application.UserName
            End If

            .RightHeader = strHeadRight
            .LeftFooter = "&10Filename: &F" & Chr(10) & "Sheet: &A"
            '.CenterFooter = strFootCenter
            .RightFooter = _
              "&10Page &P of &N"
        End With
    Else
        MsgBox "Sheet Template does not exist." & vbCrLf & _
        "For this reason, the header and footer cannot be inserted into newly created spreadsheets.", _
        vbExclamation, "No Headers In Memory"
    End If
    Application.ScreenUpdating = True
End Sub

在保存事件时创建 header 和页脚。检查 header 或页脚是否存在

Create header and footer on save event. Check if header or footer exists

excel

vba

excel-2010