Excel2010のVBAでライトヘッダーが出ない
2020/10/12 OKウェイヴ 質問
Excel2010にて、VBAで以下を実行すると
ライトヘッダーの日付が印刷されません。
ライトヘッダーの日付が出力されるようにするには
どの部分をどのように修正する必要があるでしょうか。
日付が表示されない理由、表示されるようになるための修正点を教えていただきますようお願いします。
※初心者が記録されたマクロを修正しただけなので コードが汚いなどは気にしないでください。
また、テキスト部分は内容を修正してあります。
Cells(1, 1).Select
Application.PrintCommunication = False
Worksheets(Worksheets.Count).Copy After:=Worksheets(Worksheets.Count)
With ActiveSheet.PageSetup
.RightHeader = "&""メイリオ,レギュラー""&D"
.LeftFooter = "&""メイリオ,レギュラー""テキスト" & vbLf & "テキスト"
.RightFooter = "&""メイリオ,レギュラー""テキスト" & vbLf & "テキスト" & vbLf & "テキスト"
.LeftMargin = Application.InchesToPoints(0.984251968503937)
.RightMargin = Application.InchesToPoints(0.984251968503937)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1.18110236220472)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.4)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.PrintTitleRows = "$1:$1"
End With
Range("U:U").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("ZZ1"), Unique:=True
Range("A1").AutoFilter Field:=17, Criteria1:="<>"
Range("A1", Selection.End(xlToRight)).EntireColumn.AutoFit
Selection.ShrinkToFit = True
Range("A:L,N:P,R:V,ZZ:ZZ").EntireColumn.Hidden = True
Range("A1", Selection.End(xlToRight)).EntireColumn.Select
ActiveSheet.PageSetup.PrintArea = ActiveCell.CurrentRegion.Address
With Selection.Font
.Name = "Meiryo UI"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Dim i As Integer
i = 2
Do While Cells(i, "ZZ") <> ""
Range("A1").AutoFilter Field:=21, Criteria1:=Cells(i, "ZZ")
If Cells(Rows.Count, "Q").End(xlUp) <> "参照先" Then
ActiveSheet.PageSetup.LeftHeader = "&""メイリオ,レギュラー""" & Cells(Rows.Count, "U").End(xlUp) & "テキスト" & vbLf & "テキスト"
Application.PrintCommunication = True
ActiveSheet.PrintOut
Application.PrintCommunication = False
End If
i = i + 1
Loop
Range("B2").Select
End Sub
お礼
ご回答ありがとうございます。 私ができないのか、、、 自身がありませんが、作成できませんでした。 宜しければ、引き続きご指導下されば幸いでございます。