26.03.2019, 12:51
Hallo zusammen,
habe mal wieder ein Problem womit ich nicht weiter komme.
Aus dem Netz habe ich ein tolles Makro (danke an den Urheber) das mir Daten in die Kopf- und Fußzeile einer Tabelle schreibt.
Es gelingt mir aber nicht das Teil so abzuändern, dass auf der letzten Seite der "RightFooter" ein anderer Eintrag eingefügt werden kann.
Es werden immer auf allen Seiten der zuvor eingetragene Text überschrieben.
Gibt es dazu eine mögliche Lösung?
Hier das Makro:
Vielen Dank für Eure Hilfe!
habe mal wieder ein Problem womit ich nicht weiter komme.
Aus dem Netz habe ich ein tolles Makro (danke an den Urheber) das mir Daten in die Kopf- und Fußzeile einer Tabelle schreibt.
Es gelingt mir aber nicht das Teil so abzuändern, dass auf der letzten Seite der "RightFooter" ein anderer Eintrag eingefügt werden kann.
Es werden immer auf allen Seiten der zuvor eingetragene Text überschrieben.
Gibt es dazu eine mögliche Lösung?
Hier das Makro:
Code:
Sub KopfzeileAnlegen()
'
' KopfzeileAnlegen Makro
' Legt eine Kopfzeile mit Namen, Erstell-, und Änderungsdatum an.
'
'Christian Falke, 2016
'Definiere Variablen für den Inhalt der linken und rechten Kopfzeile
Dim KopfLinks As String
Dim KopfRechts As String
Dim Startseite
'Schreibe den Inhalt der Kopfzeilen in die Variablen
KopfLinks = ActiveSheet.PageSetup.LeftHeader
KopfRechts = ActiveSheet.PageSetup.RightHeader
Dim Author As String 'Variable nimmt den Systembenutzernamen des Erstellers als Autor auf
Dim Company As String ' Wenn der Firmenname im System vorhanden ist, wird dieser links gewählt
Dim LastAuthor As String 'Variable nimmt den Systemnamen des letzten Dokumentbenutzers auf
Dim CreaDate As Date 'Variable nimmt Erstellungsdatum der Datei auf
Startseite = 1
'Autor und Datum aus Excel Metadaten auslesen
Author = ActiveWorkbook.BuiltinDocumentProperties("Author")
Company = ActiveWorkbook.BuiltinDocumentProperties("Company")
LastAuthor = ActiveWorkbook.BuiltinDocumentProperties("Last author")
CreaDate = Fix(ActiveWorkbook.BuiltinDocumentProperties("Creation Date")) 'Fix löscht die Nachkommastelle der Ganzzahl und damit die Uhrzeit
AnzSeiten = ActiveSheet.PageSetup.Pages.Count
'Für Privatpersonen empfiehlt es sich den eigenen Namen in der linken Kopfzeile zu führen, daher eine Inhaltsprüfung
If Company = "" Then
Company = "" 'Author
End If
For i = Startseite To AnzSeiten
'Left=Links; Center=Mitte; Right=Rechts
'Header=Kopfzeile; Footer=Fußzeile
If Startseite = AnzSeiten Then
With ActiveSheet.PageSetup
' Kopf und Fusszeile auf der letzten Seite ändern.
'Fußzeile Rechts
ActiveSheet.PageSetup.RightFooter = "Stopp"
End With
Else
' Kopf- und Fußzeile für erste bis vorletzte Seite
'Prüft ob die Kopfzeile leer ist
If KopfLinks & KopfRechts = "" Then
With ActiveSheet.PageSetup
.FirstPageNumber = Startseite
'Inhalt der ersten Zelle (A1) als Überschrift in der Kopfzeile
'.LeftHeader = Company
.LeftHeader = "&""ARIAL,Fett""&12" & Range("A1")
.CenterHeader = ""
.RightHeader = "Erstellt am: " & CreaDate & Chr(10) & "Geändert am: &D"
'.RightHeader = "Erstellt am: " & CreaDate & " von: " & Author & Chr(10) & "Geändert am: &D von: " & Author
.LeftFooter = "X. XXXXXX"
.CenterFooter = " Seite &p von &n"
.RightFooter = "weiter lesen ....."
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
End With
'Wenn nicht, wird der rechte Teil lediglich aktualisiert
Else
With ActiveSheet.PageSetup
.RightHeader = "Erstellt am: " & CreaDate & Chr(10) & "Geändert am: &D"
'.RightHeader = "Erstellt am: " & CreaDate & " von: " & Author & Chr(10) & "Geändert am: &D von: " & Author
End With
End If
End If
Startseite = Startseite + 1
Next
End Sub
Vielen Dank für Eure Hilfe!