Kopfzeile mit vba füllen - Macht was es will
02.07.2015 10:39:10
Christoph
ich habe ein Makro erstellt, welches Daten aus benutzerdefinierten Eigenschaften in die Kopfzeile bzw. Fußzeile aller Tabellenblätter schreiben soll. Eigentlich funktioniert es, allerdings mit Einschränkungen:
1. Manchmal übernimmt er den aktualisierten Text nicht
2. Manchmal schreibt er den Text woanders hin (also z.B. Seitenzahl nicht rechts unten sondern links oben
3. Manchmal zeigt er mir den alten Text durchgestrichen an
4. Manchmal kommt der Fehler wg. den maximalen Zeichen, obwohl ich davor alle Zeichen rauslösche und in Summe weniger wie 160 Zeichen in die Kopfzeile geschrieben werden.
Anbei mein Code:
Sub Header_aktualisieren()
Dim i As Integer
Dim strTabName As String
Dim strTextCenter As String
Dim strTextRight As String
Application.ScreenUpdating = False
Application.PrintCommunication = False
strTabName = ActiveSheet.Name
With ThisWorkbook
strTextCenter = .CustomDocumentProperties("_KAM_Projbez") & vbLf & _
.CustomDocumentProperties("_KAM_Gewerk") & vbLf & _
.CustomDocumentProperties("_KAM_Dokumentenart") & vbLf & _
.CustomDocumentProperties("_KAM_DokTitel")
Debug.Print Len(strTextCenter)
If .CustomDocumentProperties("_KAM_Send") = True Then
strTextRight = "Revision: " & .CustomDocumentProperties("_KAM_RevNr") & vbLf & _
"Version: " & .CustomDocumentProperties("_KAM_VerNr") & vbLf & _
"Datum: " & .CustomDocumentProperties("_KAM_RefDatum") & vbLf & _
"Bearbeiter: " & .CustomDocumentProperties("_KAM_RefName") & vbLf
Else
strTextRight = "Erstausgabe" & vbLf & _
"Version: " & .CustomDocumentProperties("_KAM_VerNr_Ers") & vbLf & _
"Datum: " & .CustomDocumentProperties("_KAM_ErsDat") & vbLf & _
"Bearbeiter: " & .CustomDocumentProperties("_KAM_ErstNam") & vbLf
End If
If .CustomDocumentProperties("_KAM_AngProj") = "Projekt" Then
strTextRight = strTextRight & "Projekt-Nr: " & .CustomDocumentProperties(" _
_KAM_ProjNummer")
Else
strTextRight = strTextRight & "Angebots-Nr: " & .CustomDocumentProperties(" _
_KAM_ProjNummer")
End If
Debug.Print Len(strTextRight)
End With
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets.Item(i).Name "CoverSheet" Then
Sheets.Item(i).Activate
With ActiveSheet.PageSetup
.LeftHeader = "."
.CenterHeader = " "
.RightHeader = " "
.RightFooter = "."
.CenterFooter = "."
.LeftFooter = "."
End With
End If
Next i
For i = 1 To ActiveWorkbook.Sheets.Count
If Sheets.Item(i).Name "CoverSheet" Then
Sheets.Item(i).Activate
With ActiveSheet.PageSetup
.CenterHeader = "&""Arial,Fett""&8 " & strTextCenter
.RightHeader = "&""Arial""&6 " & strTextRight
.RightFooter = "&""Arial,Fett""&8&P von/of &N"
.CenterFooter = "&8&H&A"
.LeftFooter = "&6&Z&F"
End With
End If
Next i
Sheets.Item(strTabName).Activate
Application.PrintCommunication = True
Application.ScreenUpdating = True
End Sub
Anzeige