Dynamische Kopf-/Fußzeile

[Excellehrling]

Guten Abend zusammen,

mir liegt folgende Frage vor die mir Google und Co. bisher nicht beantworten konnte.

Ich muss des öfteren eine Artikelliste mit Lagerplätzen ausdrucken. Diese ist lang und daher schon unübersichtlich. Mein versuch war es in der Kopfzeile immer die erste und letze Zelle der Spalte "Artikelnummer" je Blatt anzeigen zu lassen. So wie in einem Lexikon - Erster und Letzter Beitrag pro Seite.

Hier eine Beispielbild

[
Bild bitte so als Datei hochladen: Klick mich!
]

Wie bekomme ich dort eine dynamische Zeile hin?

Vielen Dank schonmal im vorraus

Excellehrling

[RPP63]

Hallo!
Interessante Aufgabenstellung!
Mit Bordmitteln ist da nichts zu machen.
Tatsächlich konnte ich im INet nichts finden!
Daher mal Eigenleistung:

Grober Ablauf:
- Schleife über alle horizontale Seitenumbrüche,
- auslesen der Position und des jew. Spaltenwerts
- Seite einrichten (Kopfzeile mittels Variablen der ersten und letzten Zeile)
- Druck der einzelnen Seite

Die Sonderfälle erste und letzte Seite müssen separat behandelt werden:

Sub ArtPerPage()

Dim Art1 As String, Art2 As String

Dim hpb As Long

With Tabelle1

  Art1 = .Cells(2, 1)

  Art2 = .Cells(.HPageBreaks(1).Location, 1)

  .PageSetup.RightHeader = "Artikel von: " & Art1 & " bis: " & Art2

  .PrintOut From:=hpb + 1, To:=hpb + 1

  For hpb = 1 To .HPageBreaks.Count - 1

     Art1 = .Cells(.HPageBreaks(hpb).Location, 1).Offset(1, 0)

     Art2 = .Cells(.HPageBreaks(hpb + 1).Location, 1)

     .PageSetup.RightHeader = "Artikel von: " & Art1 & " bis: " & Art2

     .PrintOut From:=hpb + 1, To:=hpb + 1

  Next

  Art1 = .Cells(.HPageBreaks(.HPageBreaks.Count).Location, 1).Offset(1, 0)

  Art2 = .Cells(.Rows.Count, 1).End(xlUp)

  .PageSetup.RightHeader = "Artikel von: " & Art1 & " bis: " & Art2

  .PrintOut From:=.HPageBreaks.Count + 1, To:=.HPageBreaks.Count + 1

End With

End Sub

Gruß Ralf

[Excellehrling]

Hallo Ralf,
danke für deine schnelle Antwort. Und ich muss sagen für mein erstes Mal mit VBA echt wenig Fehlermeldungen :19: 
Irgendwas fehlt noch das werde ich morgen prüfen, dann stell ich noch eine Beispieldatei da es wohl doch nicht soo leicht ist.
Schön das es aber für diese Herrausforderung eine Lösung zu geben scheint.

[RPP63]

Moin!
In der Testphase hatte ich die Seitenlayout-Ansicht eingestellt, um die Auswirkungen im Einzelschritt-Verfahren am Bildschirm verfolgen zu können.
Erstaunlicherweise funktioniert das Makro auch nur in dieser Ansicht!
In der Normalansicht läuft es in den LZF 9 (Index außerhalb), warum auch immer.
Workaround:
Screenupdating ausschalten, Ansicht temporär auf Seitenlayout und zum Abschluss wieder auf die alte Ansicht zurückstellen.

Modul Modul1

Option Explicit 

Sub ArtPerPage() 

Dim Art1 As String, Art2 As String 

Dim hpb As Long, oldPageView As Byte 

'Bildschirmaktualisierung aus 

Application.ScreenUpdating = False 

'aktuelle Ansicht zwischenspeichern 

oldPageView = ActiveWindow.View 

'auf Seitenlayout umschalten 

ActiveWindow.View = xlPageLayoutView 

With Tabelle1 

  Art1 = .Cells(2, 1) 

  Art2 = .Cells(.HPageBreaks(1).Location, 1) 

  .PageSetup.RightHeader = "Artikel von: " & Art1 & " bis: " & Art2 

  .PrintOut From:=hpb + 1, To:=hpb + 1 

  For hpb = 1 To .HPageBreaks.Count - 1 

     Art1 = .Cells(.HPageBreaks(hpb).Location, 1).Offset(1, 0) 

     Art2 = .Cells(.HPageBreaks(hpb + 1).Location, 1) 

     .PageSetup.RightHeader = "Artikel von: " & Art1 & " bis: " & Art2 

     .PrintOut From:=hpb + 1, To:=hpb + 1 

  Next 

  Art1 = .Cells(.HPageBreaks(.HPageBreaks.Count).Location, 1).Offset(1, 0) 

  Art2 = .Cells(.Rows.Count, 1).End(xlUp) 

  .PageSetup.RightHeader = "Artikel von: " & Art1 & " bis: " & Art2 

  .PrintOut From:=.HPageBreaks.Count + 1, To:=.HPageBreaks.Count + 1 

End With 

'auf ursprünglche Ansicht zurückschalten 

ActiveWindow.View = oldPageView 

End Sub 

Ich habe mal meine Datei angehängt (sind nur drei Seiten), bitte prüfen.
Anmerkung:
Das Page-Setup benötigt natürlich eine gewisse Zeit!
Wenn 1.000 Seiten ausgedruckt werden sollen, würde ich das über Nacht laufen lassen ...

Gruß Ralf