Problem Druckvorschau
21.10.2021 10:44:28
Peter
ich habe ein Problem mit der Druckvorschau gestartet aus Userform und bitte um eure Hilfe.
Wenn ich die Druckvorschau mit dem nachstehenden Makro ausführe, dann kann ich
in der Druckvorschau von der ersten bis letzten Seite scrollen.
Sub Makro3a_Druckvorschau()
ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PageSetup.PrintArea = "$B$1:$H$1343"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = "$B$1:$H$1343"
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.78740157480315)
.RightMargin = Application.InchesToPoints(0.236220472440945)
.TopMargin = Application.InchesToPoints(0.748031496062992)
.BottomMargin = Application.InchesToPoints(0.748031496062992)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = -3
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 85
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
ActiveSheet.PrintPreview
ActiveSheet.PageSetup.PrintArea = ""
End Sub
'Drucken Vorschau
Private Sub CommandButton3_Click()
Dim wb As Workbook
Dim wksTB1 As Worksheet, lngZeile As Long, lngZBox As Long, lngSpalte
Dim lngLetzte As Long
Dim strDruckbereich As String 'benötigt für Druckvorschau
Dim lngLetzteC As Long
Dim LetzteZeileE As Long
Dim LetzteZeileF As Long
Dim LetzteZeileG As Long
Dim LetzteZeileH As Long
Dim wsName As String 'benötigt für variablen Namen von Buchungstabelle
Dim wksQ As Worksheet 'benötigt für Quelltabelle
Application.ScreenUpdating = False
Set wb = ThisWorkbook
Set wksTB1 = wb.Worksheets("Tabelle1")
wsName = ComboBox3.Value
'Debug.Print wsName
Set wksQ = wb.Worksheets(wsName)
'Prüfung ob ListBox1 gefüllt ist
If ListBox1.ListCount = 0 Then
'MsgBox "listBos1 leer!"
Label17.BackColor = &HFF& 'rot
Label17.Caption = "Es wurde keine Auswahl getroffen!"
Else
'MsgBox "listBos1 nicht leer!"
'Anfang - Kontonummer in Tabelle1 Range L2 aus Combobox einfügen
wksTB1.Range("L2") = Mid(ComboBox3, InStr(ComboBox3, "_") + 1)
'Ende - Kontonummer in Tabelle1 Range L2 aus Combobox einfügen
'Anfang - bisherige Werte ab Zeile 10 in Tabelle1 entfernen
With wksTB1
lngLetzte = .Cells(Rows.Count, 3).End(xlUp).Row 'wählt die letzte, beschriebene Zelle von unten
' .Activate 'unbedingt erforderlich
If .Cells(lngLetzte + 2, 3) > "" Then
.Cells(lngLetzte + 2, 3).Resize(5, 4).ClearContents 'löscht den eingefügten Datensatz für Summen aus L16:O20 zuerst löschen sonst Fehler
End If
.Range("B10:K" & lngLetzte + 1).ClearContents 'bei dieser Version von Daniel werden die beiden Spalten I und J ausgefüllt daher entfernen
End With
'Ende - bisherige Werte ab Zeile 10 in Tabelle1 entfernen
'Anfang Übertrag der Daten der ListBox1 in Tabelle1
With ListBox1
wksTB1.Cells(10, 2).Resize(.ListCount, .ColumnCount).Value = .List
End With
'Ende Übertrag der Daten der ListBox1 in Tabelle1
'Anfang Inhalte in Spalten J und K entfernen
With wksTB1
lngLetzte = .Cells(Rows.Count, 10).End(xlUp).Row 'wählt die letzte, beschriebene Zelle von unten
.Range("J10:K" & lngLetzte).ClearContents 'bei dieser Version von Daniel werden die beiden Spalten J und K ausgefüllt daher entfernen
End With
'Ende Inhalte in Spalten J und K entfernen
'Anfang Summenfelder_kopieren_einfügen
With wksTB1
lngLetzte = .Cells(Rows.Count, 3).End(xlUp).Row 'wählt die letzte, beschriebene Zelle von unten
wksTB1.Range("L16:L21").Copy
wksTB1.Cells(lngLetzte + 2, 3).PasteSpecial xlPasteValues
wksTB1.Cells(lngLetzte + 2, 3).NumberFormat = "#,##0.00 "
wksTB1.Range("O16").Copy
wksTB1.Cells(lngLetzte + 2, 5).PasteSpecial xlPasteValues
wksTB1.Cells(lngLetzte + 2, 5).NumberFormat = "#,##0.00 "
wksTB1.Range("O17").Copy
wksTB1.Cells(lngLetzte + 3, 6).PasteSpecial xlPasteValues
wksTB1.Cells(lngLetzte + 3, 6).NumberFormat = "#,##0.00 "
wksTB1.Range("O18").Copy
wksTB1.Cells(lngLetzte + 4, 7).PasteSpecial xlPasteValues
wksTB1.Cells(lngLetzte + 4, 7).NumberFormat = "#,##0.00 "
wksTB1.Range("O19").Copy
wksTB1.Cells(lngLetzte + 5, 8).PasteSpecial xlPasteValues
wksTB1.Cells(lngLetzte + 5, 8).NumberFormat = "#,##0.00 "
wksTB1.Range("O20").Copy
wksTB1.Cells(lngLetzte + 6, 8).PasteSpecial xlPasteValues
wksTB1.Cells(lngLetzte + 6, 8).NumberFormat = "#,##0.00 "
wksTB1.Range("O21").Copy
wksTB1.Cells(lngLetzte + 7, 8).PasteSpecial xlPasteValues
wksTB1.Cells(lngLetzte + 7, 8).NumberFormat = "#,##0.00 "
End With
Application.CutCopyMode = False
'Ende Summenfelder_kopieren_einfügen
'Anfang - Spalten F, G und H in Zahl umwandeln
With wksTB1
LetzteZeileE = .Range("E65536").End(xlUp).Row
LetzteZeileF = .Range("F65536").End(xlUp).Row
LetzteZeileG = .Range("G65536").End(xlUp).Row
LetzteZeileH = .Range("H65536").End(xlUp).Row
.Range("F10:F" & LetzteZeileF).TextToColumns Destination:=Range("F10"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.Range("G10:G" & LetzteZeileG).TextToColumns Destination:=Range("G10"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.Range("H10:H" & LetzteZeileH).TextToColumns Destination:=Range("H10"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.Range("E" & LetzteZeileE).TextToColumns Destination:=Range("E" & LetzteZeileE), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.Range("E" & LetzteZeileE).NumberFormat = "#,##0.00 "
.Range("F10:F" & LetzteZeileF).NumberFormat = "#,##0.00 "
.Range("G10:G" & LetzteZeileG).NumberFormat = "#,##0.00 "
.Range("H10:H" & LetzteZeileH).NumberFormat = "#,##0.00 "
End With
'Ende - Spalten F, G und H in Zahl umwandeln
'Anfang - gewählte Kontodaten einfügen
With wksQ
With wksTB1
.Range("B6").Value = wksQ.Range("B6").Value
.Range("B7").Value = wksQ.Range("B7").Value
.Range("E3").Value = wksQ.Range("E3").Value
.Range("E7").Value = wksQ.Range("E7").Value
.Range("G5").Value = wksQ.Range("G5").Value
.Range("H3").Value = wksQ.Range("H3").Value
.Range("H7").Value = wksQ.Range("H7").Value
End With
End With
'Ende - gewählte Kontodaten einfügen
'Anfang - ab hier Druckvorschau
With wksTB1
.PageSetup.PrintArea = ""
lngLetzteC = .Cells(Rows.Count, 3).End(xlUp).Row 'wählt die letzte, beschriebene Zelle von unten
' .PageSetup.PrintArea = "$B$1:$H$1343"
.PageSetup.PrintArea = "$B$1:$H" & lngLetzteC
Application.PrintCommunication = False
With .PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
' .PageSetup.PrintArea = "$B$1:$H$1343"
.PageSetup.PrintArea = "$B$1:$H" & lngLetzteC
Application.PrintCommunication = False
With .PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.78740157480315)
.RightMargin = Application.InchesToPoints(0.236220472440945)
.TopMargin = Application.InchesToPoints(0.748031496062992)
.BottomMargin = Application.InchesToPoints(0.748031496062992)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = -3
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 85
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
Me.Hide
.PrintPreview
Me.Show
.PageSetup.PrintArea = ""
End With
'Anfang - ab hier Druckvorschau
End If 'benötigt für Prüfung, ob ListBox gefüllt ist
Application.ScreenUpdating = True
End Sub
wo der Fehler steckt.
Besten Dank
Gruss
Peter