Code ist zu langsam
18.10.2019 09:50:22
Peter
ich hätte eine Bitte an euch. Ich habe einen Code, der nach Auswahl in der ComboBox eine ListBox befüllt.
Mit dem CmdBtn3 zeige ich die Daten der UF und Listbox in der Druckvorschau an.
Dieses ist aber extrem langsam. Könnt ihr bitte einen Blick auf den Code werfen und mir mitteilen, wie das ganze beschleunigt werden kann.
Besten Dank für eure Hilfe.
Gruss
Peter
'Drucken Vorschau
<pre>Private Sub CommandButton3_Click()
Dim i As Long 'benötigt für Übertrag von ListBox1 in Tabelle1
Dim j As Long 'benötigt für Übertrag von ListBox1 in Tabelle1
Dim Zelle As Range 'benötigt für Umwandlung in Zahl in Tabelle1
Dim s As Long 'benötigt für Umwandlung in Zahl in Tabelle1
Dim zB As String 'benötigt für letzte beschriebene Zelle in Spalte B
Dim zF As String 'benötigt für letzte beschriebene Zelle in Spalte F
Dim zG As String 'benötigt für letzte beschriebene Zelle in Spalte G
Dim zH As String 'benötigt für letzte beschriebene Zelle in Spalte H
Dim zJ As String 'benötigt für letzte beschriebene Zelle in Spalte J
Dim wsName As String 'benötigt für Konoinhaber übertragen
Application.ScreenUpdating = False
'Anfang Prüfung ob ListBox1 Daten vorhanden
If ListBox1.ListCount = 0 Then
' MsgBox "Listbox leer"
Label38.BackColor = &HFF& 'rot
Label38.Font.Size = 12
Label38.Caption = " Listbox leer" & vbLf & " bitte Daten auswählen"
Exit Sub
Else
' MsgBox "Listbox nicht leer"
Label38.BackColor = &HFF00& 'grün
Label38.Font.Size = 12
Label38.Caption = " Daten ausgewählt"
'Anfang Übertrag von ListBox1 in Tabelle1
With Worksheets("Tabelle1")
Dim lngLetzte As Long 'benötigt für letzte beschriebene Zelle
lngLetzte = .Cells(Rows.Count, 7).End(xlUp).Row 'wählt die letzte, beschriebene Zelle von unten
.Range("A1:M" & lngLetzte).Clear
With UF_AnzeigenDrucken3f.ListBox1
For i = 0 To .ListCount - 1
For j = 0 To .ColumnCount - 1
Worksheets("Tabelle1").Cells(i + 10, j + 2) = .List(i, j) 'Zeile 10 Spalte 2=B
Next
Next
End With
'Ende Übertrag von ListBox1 in Tabelle1
Call Spaltenbreite_Zeilenhöhe_einstellen_Tabelle1
'Anfang Umwandlung von Zahl in Währung
zF = .Cells(Rows.Count, 6).End(xlUp).Row
'For Each Zelle In Worksheets("Tabelle1").Range("F10:F16")
For Each Zelle In Worksheets("Tabelle1").Range("F10:F" & zF)
s = Zelle.Value
If Zelle.Offset(0, -1) > "" And s > "0" And IsNumeric(s) Then
s = s * 1 'hier wird von Text in Zahl umgewandelt
Zelle.Value = s
Zelle.NumberFormat = "#,##0.00 " 'hiermit wird auf Währung umgestellt
ElseIf Zelle.Offset(0, -1) = "" Then
Zelle = ""
ElseIf Zelle.Offset(0, -1) > "" And s = "0" Then
Zelle = ""
End If
Next Zelle
zG = .Cells(Rows.Count, 7).End(xlUp).Row
'For Each Zelle In Worksheets("Tabelle1").Range("G10:G16")
For Each Zelle In Worksheets("Tabelle1").Range("G10:G" & zG)
s = Zelle.Value
If Zelle.Offset(0, -2) > "" And s > "0" And IsNumeric(s) Then
s = s * 1 'hier wird von Text in Zahl umgewandelt
Zelle.Value = s
Zelle.NumberFormat = "#,##0.00 " 'hiermit wird auf Währung umgestellt
ElseIf Zelle.Offset(0, -2) = "" Then
Zelle = ""
ElseIf Zelle.Offset(0, -2) > "" And s = "0" Then
Zelle = ""
End If
Next Zelle
zH = .Cells(Rows.Count, 8).End(xlUp).Row
For Each Zelle In Worksheets("Tabelle1").Range("H10:H" & zH)
s = Zelle.Value
If Zelle.Offset(0, -3) > "" And s > "0" And IsNumeric(s) Then
s = s * 1 'hier wird von Text in Zahl umgewandelt
Zelle.Value = s
Zelle.NumberFormat = "#,##0.00 " 'hiermit wird auf Währung umgestellt
ElseIf Zelle.Offset(0, -3) = "" Then
Zelle = ""
ElseIf Zelle.Offset(0, -3) > "" And s = "0" Then
Zelle = ""
End If
Next Zelle
'Ende Umwandlung von Zahl in Währung
'Anfang Kontoinhaber übertragen
Dim dDatum As Date, lZeile As Long ', i As Long
'''Worksheets("Tabelle1").Activate
With Worksheets("Kontodaten")
lZeile = .Cells(.Rows.Count, 8).End(xlUp).Row
For i = 2 To lZeile
dDatum = .Cells(i, 8)
' If dDatum >= .Cells(i, 2) Then
If dDatum >= TextBox2 Then
' If dDatum <= .Cells(i, 3) Then
If dDatum <= TextBox3 Then
' .Range(.Cells(i, 5), .Cells(lZeile, 5)) = .Cells(1, 16)
Label43.Caption = "Datumwert übertragen"
Worksheets("Tabelle1").Range("B1") = .Cells(i, 1) 'Inh_N 'Sheets(wsName).Range("B1")
Worksheets("Tabelle1").Range("B2") = .Cells(i, 2) 'Inh_S 'Sheets(wsName).Range("B2")
Worksheets("Tabelle1").Range("B3") = .Cells(i, 3) 'Inh_PLZ 'Sheets(wsName).Range("B3")
Worksheets("Tabelle1").Range("C3") = .Cells(i, 4) 'Inh_Ort 'Sheets(wsName).Range("C3")
Worksheets("Tabelle1").Range("C4") = .Cells(i, 5) 'Inh_Tel 'Sheets(wsName).Range("C4")
Exit For
Else
Label43.Caption = "kein Datumwert vorhanden"
Worksheets("Tabelle1").Range("B1") = False 'Inh_N 'Sheets(wsName).Range("B1")
Worksheets("Tabelle1").Range("B2") = False 'Inh_S 'Sheets(wsName).Range("B2")
Worksheets("Tabelle1").Range("B3") = False 'Inh_PLZ 'Sheets(wsName).Range("B3")
Worksheets("Tabelle1").Range("C3") = False 'Inh_Ort 'Sheets(wsName).Range("C3")
Worksheets("Tabelle1").Range("C4") = False 'Inh_Tel 'Sheets(wsName).Range("C4")
End If
End If
Next i
End With
'Anfang Kontoinhaber übertragen
wsName = Me.ComboBox3.Value 'übernimmt Kontoname für Kontoinhaber übertragen
.Range("B4") = Sheets(wsName).Range("B4")
.Range("B5") = Sheets(wsName).Range("B5")
.Range("B6") = Sheets(wsName).Range("B6")
.Range("B7") = Sheets(wsName).Range("B7")
.Range("D3") = Sheets(wsName).Range("D3")
.Range("E3") = Sheets(wsName).Range("E3")
.Range("D4") = Sheets(wsName).Range("D4")
.Range("E4") = Sheets(wsName).Range("E4")
.Range("G3") = Sheets(wsName).Range("G3")
.Range("H3") = Sheets(wsName).Range("H3")
.Range("G4") = Sheets(wsName).Range("G4")
.Range("H4") = Sheets(wsName).Range("H4")
.Range("F5") = Sheets(wsName).Range("F5")
.Range("G5") = Sheets(wsName).Range("G5")
.Range("F6") = Sheets(wsName).Range("F6")
.Range("G6") = Sheets(wsName).Range("G6")
.Range("G7") = Sheets(wsName).Range("G7")
.Range("G8") = Sheets(wsName).Range("G8")
.Range("H7") = Sheets(wsName).Range("H7")
.Range("H8") = Sheets(wsName).Range("H8")
'Ende Kontoinhaber übertragen
'Anfang Überschriften
.Range("B9") = Sheets(wsName).Range("B9")
.Range("C9") = Sheets(wsName).Range("C9")
.Range("D9") = Sheets(wsName).Range("D9")
.Range("E9") = Sheets(wsName).Range("E9")
.Range("F9") = Sheets(wsName).Range("F9")
.Range("G9") = Sheets(wsName).Range("G9")
.Range("H9") = Sheets(wsName).Range("H9")
'Ende Überschriften
'Anfang Übertrag der Salden
.Range("B65536").End(xlUp).Offset(2, 3) = Me.Label23
.Range("B65536").End(xlUp).Offset(3, 3) = CDbl(Me.Label21)
.Range("B65536").End(xlUp).Offset(3, 3).NumberFormat = "#,##0.00 "
.Range("B65536").End(xlUp).Offset(2, 4) = Me.Label24
.Range("B65536").End(xlUp).Offset(3, 4) = CDbl(Me.Label6)
.Range("B65536").End(xlUp).Offset(3, 4).NumberFormat = "#,##0.00 "
.Range("B65536").End(xlUp).Offset(2, 5) = Me.Label25
.Range("B65536").End(xlUp).Offset(3, 5) = CDbl(Me.Label7)
.Range("B65536").End(xlUp).Offset(3, 5).NumberFormat = "#,##0.00 "
.Range("B65536").End(xlUp).Offset(4, 5) = Me.Label26
.Range("B65536").End(xlUp).Offset(5, 5) = CDbl(Me.Label8)
.Range("B65536").End(xlUp).Offset(5, 5).NumberFormat = "#,##0.00 "
.Range("B65536").End(xlUp).Offset(2, 6) = Me.Label27
.Range("B65536").End(xlUp).Offset(3, 6) = CDbl(Me.Label22)
.Range("B65536").End(xlUp).Offset(3, 6).NumberFormat = "#,##0.00 "
'Ende Übertrag der Salden
'Anfang Spalte J u K leeren - wegen Drucken
zJ = .Cells(Rows.Count, 10).End(xlUp).Row
.Range("J2:K" & zJ).Clear
'Ende Spalte J u K leeren - wegen Drucken
Application.ScreenUpdating = True
'Anfang Druckauswahl
Me.Hide 'aktuelle Userform ausblenden
Dim a% 'benötigt für Prüfung, ob Bereich A:H leer ist
a = Application.WorksheetFunction.CountA(Worksheets("Tabelle1").[A:H])
If a > 0 Then
' MsgBox "nicht Leer"
With Worksheets("Tabelle1")
With .PageSetup
.PrintArea = ""
.PrintArea = "$B$1:$H$" & lngLetzte
.PrintTitleRows = "$1:$9"
.PrintTitleColumns = ""
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintGridlines = True
.CenterHeader = ThisWorkbook.Name
.LeftFooter = "Ausdruck vom &D"
.RightFooter = "Seite &P von &N"
.Zoom = 80
End With
.PrintPreview 'Druckbereich Vorschau
'.PrintOut 'Ausdrucken
.PageSetup.PrintArea = "" 'Druckbereich wieder aufheben
Me.Show 'Userform wieder öffnen
End With
Else
MsgBox "Leer"
Me.Show
End If
'Ende Druckauswahl
End With
End If
'Ende Prüfung ob ListBox1 Daten vorhanden
End Sub</pre>