AW: Kopfzeile ändern
19.01.2009 14:56:00
fcs
Hallo Georg,
kopiere alle Dateien, deren Kopfzeile im 1. Tabellenblatt geändert werden soll in ein leeres Verzeichnis (Sicherheitsmassnahme).
Mit dem folgenden Makro kannst du gezielt bestimmte Kopf- und Fusszeilen unter Seiteeinrichten für alle Dateien im Verzeichnis anpassen.
Gruß
Franz
Sub KopfzeilenAnpassen()
'Mittlere Kopfzeile in Dateien anpassen im 1. Tabellenblatt
Call TabellenBearbeiten(strVerzeichnis:="C:\Lokale Daten\Test\Daten", _
arrKopfFuss:=Array(2), arrKopfFussTexte:=Array("SMT-Linie 2"))
End Sub
Sub TabellenBearbeiten(strVerzeichnis As String, arrKopfFuss, arrKopfFussTexte)
' In allen Datein des Verzeichnisses in den Tabellenblättern die Kopf- und _
Fusszeilentext ändern.
Dim wb As Workbook, wks As Worksheet, iCount As Long
Dim Dateiname As Variant, intI As Integer, strFullname As String
'strVerzeichnis = Verzeichnis mit den Dateien
'arrKopfFuss = Array mit Nrn für die Kopf-Fussteile, die angepasst werden sollen _
1 = Kopftext links _
2 = Kopftext mitte _
3 = Kopftext rechts _
4 = Fusstext links _
5 = Fusstext mitte _
6 = Fusstext rechts _
'arrKopfFussTexte = Array mit den zugehörigen neuen texten
'Beispiel für Sub-Aufruf (Kopftext-Mitte und Fusstext-Links werden angepasst):
'Call TabellenBearbeiten(strVerzeichnis:="C:\Lokale Daten\Test\Daten", _
arrKopfFuss:=Array(2, 4), _
arrKopfFussTexte:=Array("SMT-Linie 2", "Vorname Nachname"))
Dateiname = Dir(strVerzeichnis & Application.PathSeparator & "*.xls")
Application.ScreenUpdating = False
Do Until Dateiname = ""
iCount = iCount + 1
Application.StatusBar = iCount & ". Datei wird bearbeitet: " & Dateiname
strFullname = strVerzeichnis & Application.PathSeparator & Dateiname
Application.Workbooks.Open Filename:=strFullname
Set wb = ActiveWorkbook
Set wks = wb.Worksheets(1)
With wks.PageSetup
For intI = LBound(arrKopfFuss) To UBound(arrKopfFuss)
Select Case arrKopfFuss(intI)
Case 1: .LeftHeader = arrKopfFussTexte(intI)
Case 2: .CenterHeader = arrKopfFussTexte(intI)
Case 3: .RightHeader = arrKopfFussTexte(intI)
Case 4: .LeftFooter = arrKopfFussTexte(intI)
Case 5: .CenterFooter = arrKopfFussTexte(intI)
Case 6: .RightFooter = arrKopfFussTexte(intI)
End Select
Next
End With
Application.DisplayAlerts = False
wb.Close savechanges:=True
Application.DisplayAlerts = True
Dateiname = Dir
Loop
Application.ScreenUpdating = True
Application.StatusBar = False
MsgBox "Fertig", vbOKOnly, "Kopf- und Fusszeilen anpassen"
End Sub