gibt es eine Möglichkeit, ein Blatt welches als "Vorlage" dient so zu kopieren dass auch die Seiteneinstellungen, wie z. B. A4quer, der festgelegte Druckbereich und die festgelegten Wiederholungszeilen mit kopiert werden?
Gruss
René
Sub Adr_Listen()
'LArt = "A"
LTitel = ""
' Vorlage holen
Sheets("VL").Select
Cells.Select
Selection.Copy
Sheets("Druck").Select
Cells.Select
ActiveSheet.Paste
Select Case LArt
Case "A": ' Aktive
LTitel = "Aktivmitglieder"
Case "P": ' Passive
LTitel = "Passivmitglieder"
Case "EM": ' Ehrenmitglieder
LTitel = "Ehrenmitglieder"
Case "FM": ' Freimitglieder
LTitel = "Freimitglieder"
Case "JM": ' Jungmitglieder
LTitel = "Jungmitglieder"
Case "V": ' Vorstand
LTitel = "Vorstand"
Case "G": ' Gönner
LTitel = "Gönner"
Case "IN": ' Inserent
LTitel = "Inserenten"
Case "Neu": '
LTitel = "Neuanmeldungen"
Case "Fa": '
LTitel = "Spezielle Adressen"
' Case "Del": '
' LTitel = "Delegierte"
Case "Del": '
LTitel = "Ausgetretene Mitglieder"
Case Else: Exit Sub
End Select
Range("A1").Value = LTitel
SZähler = 3
For LZähler = 2 To 201
' Datensatz holen, nach LArt
Sheets("Sta").Select
If Range("AA" & LZähler).Value = LArt Then
' DS übernehmen
Wert01 = Range("B" & LZähler).Value
Wert02 = Range("C" & LZähler).Value
Wert03 = Range("D" & LZähler).Value
Wert04 = Range("E" & LZähler).Value
Wert05 = Range("F" & LZähler).Value
Wert06 = Range("G" & LZähler).Value
Wert07 = Range("H" & LZähler).Value
Wert08 = Range("I" & LZähler).Value
Wert09 = Range("J" & LZähler).Value
Wert10 = Range("K" & LZähler).Value
Wert11 = Range("L" & LZähler).Value
Wert12 = Range("M" & LZähler).Value
Sheets("Druck").Select
Range("A" & SZähler).Value = Wert01
Range("B" & SZähler).Value = Wert02
Range("C" & SZähler).Value = Wert03
Range("D" & SZähler).Value = Wert04
Range("E" & SZähler).Value = Wert05
Range("F" & SZähler).Value = Wert06
Range("G" & SZähler).Value = Wert07
Range("H" & SZähler).Value = Wert08
Range("I" & SZähler).Value = Wert09
Range("J" & SZähler).Value = Wert10
Range("K" & SZähler).Value = Wert11
Range("L" & SZähler).Value = Wert12
' Rahmen festlegen
Range("A" & SZähler & ":L" & SZähler).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
If SZähler = 3 Then
Range("A" & SZähler - 1 & ":L" & SZähler - 1).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End If
SZähler = SZähler + 1
End If
Next LZähler
' Einträge sortieren
Sheets("Druck").Select
Range("A3:L" & SZähler - 1).Select
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Key2:=Range("B3"), _
Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
' Drucken
ActiveWindow.SelectedSheets.PrintPreview
Antwort = MsgBox("Liste " & LTitel & " drucken ?", vbYesNo)
If Antwort = Yes Then
Druck_Neu
End If
Cells.Select
Selection.Clear
Range("A5").Select
Druck
End Sub
Sub Adr_Listen_VS()
'LArt = "A"
LTitel = ""
' Vorlage holen
Sheets("VL1").Select
Cells.Select
Selection.Copy
Sheets("Druck").Select
Cells.Select
ActiveSheet.Paste
Case "V": ' Vorstand
LTitel = "Vorstand"
Case Else: Exit Sub
End Select
Range("A1").Value = LTitel
SZähler = 3
For LZähler = 2 To 201
' Datensatz holen, nach LArt
Sheets("Sta").Select
If Range("AF" & LZähler).Value = LArt Then
' DS übernehmen
Wert01 = Range("B" & LZähler).Value
Wert02 = Range("C" & LZähler).Value
Wert03 = Range("D" & LZähler).Value
Wert04 = Range("F" & LZähler).Value
Wert05 = Range("G" & LZähler).Value
Wert06 = Range("I" & LZähler).Value
Wert07 = Range("J" & LZähler).Value
Wert08 = Range("K" & LZähler).Value
Wert09 = Range("L" & LZähler).Value
Wert10 = Range("M" & LZähler).Value
Wert11 = Range("V" & LZähler).Value
Wert12 = Range("Z" & LZähler).Value
Sheets("Druck").Select
Range("A" & SZähler).Value = Wert01
Range("B" & SZähler).Value = Wert02
Range("C" & SZähler).Value = Wert03
Range("D" & SZähler).Value = Wert04
Range("E" & SZähler).Value = Wert05
Range("F" & SZähler).Value = Wert06
Range("G" & SZähler).Value = Wert07
Range("H" & SZähler).Value = Wert08
Range("I" & SZähler).Value = Wert09
Range("J" & SZähler).Value = Wert10
Range("K" & SZähler).Value = Wert11
Range("L" & SZähler).Value = Wert12
' Rahmen festlegen
Range("A" & SZähler & ":L" & SZähler).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlHairline
.ColorIndex = xlAutomatic
End With
If SZähler = 3 Then
Range("A" & SZähler - 1 & ":L" & SZähler - 1).Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
End If
SZähler = SZähler + 1
End If
Next LZähler
' Einträge sortieren
Sheets("Druck").Select
Range("A3:L" & SZähler - 1).Select
Selection.Sort Key1:=Range("L3"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Columns("L:L").Select
Selection.Delete
' Drucken
ActiveWindow.SelectedSheets.PrintPreview
Antwort = MsgBox("Liste " & LTitel & " drucken ?", vbYesNo)
If Antwort = Yes Then
Druck_Neu
End If
Cells.Select
Selection.Clear
Range("A5").Select
Druck
End Sub