Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1716to1720
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Code ist zu langsam

Code ist zu langsam
18.10.2019 09:50:22
Peter
Hallo,
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>

19
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Code ist zu langsam
18.10.2019 10:02:35
Daniel
HI
vermeide die Bearbeitung von einzelnen Zellen.
immer wenn du direkt nebeneinander liegende Zellen in gleicher weise bearbeitest, solltet du prüfen ob nicht Blockbearbeitung möglich ist
beispielsweise lässt sich das hier:
'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

in einem Schritt durchführen:
'Anfang Überschriften
.Range("B9:H9") = Sheets(wsName).Range("B9:H9")
'Ende Überschriften
gleiches Prinzip kannst du an mehreren Stellen im Code anwenden, manchmal etwas abewandelt:
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")

wird zu
Worksheets("Tabelle1").Range("B1:B3,C3:C4") = False
oder das hier:
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

wird zu:
With UF_AnzeigenDrucken3f.ListBox1
Worksheets("Tabelle1").Cells(10, 2).Resize(.listcount, .colmnscount).Value = .List
End With
Gruß Daniel
Anzeige
AW: Teste deine Hilfestellung
18.10.2019 10:49:13
Peter
Hallo Daniel,
besten Dank für Deine Hilfe.
Ich teste das Ganze mal schrittweise.
Melde mich dann wieder.
Gruss
Peter
AW: sehe keine Stelle mehr...
18.10.2019 10:56:46
Peter
Hallo Daniel,
ich habe jetzt Deine Vorschläge umgebaut. Deutliche Verkürzung der Zeit.
Ich sehe keine weiteren Änderungsmöglichkeiten.
Kannst Du mir noch einen Tipp geben, wo noch Potential vorhanden ist um die Zeit noch kürzer zu gestalten.
Besten Dank
Gruss
Peter
AW: sehe keine Stelle mehr...
18.10.2019 11:12:25
Daniel
naja so auf die schnelle ohne den Code zu kennen natürlich nicht so einfach.
hast du auch das Umwandeln der Zellen mit textzahl in echte Zahl schon umgestellt?
das geht beispielsweise auch super schnell wenn man nicht jede Zelle einzeln mit 1 multipliziert, sondern
1. eine leere Zelle kopiert
2. diese Zelle dann in den umzuwandelnden Zellbereich mit dem Vorgang "addieren" einfügt
(für die Umsetzung in VBA bitte den Recorder bemühen, bzw beim PasteSpecial den Parameter "Operation:=xladd" verwenden.
Gruß Daniel
Anzeige
AW: sehe keine Stelle mehr...
18.10.2019 11:30:48
Peter
Hallo Daniel,
ich habe doch in meiner ersten Anfrage den Code mitgeteilt.
Werde zwischenzeitlich Deinen Tipp ausprobieren.
Gruss
Peter
AW: sehe keine Stelle mehr...
18.10.2019 11:36:32
Daniel
meinte auch die Datei
AW: sehe keine Stelle mehr...
18.10.2019 11:38:12
Daniel
außerdem weiß ich ja nicht, was du inzwischen geändert hast und was nicht.
Gruß Daniel
AW: sehe keine Stelle mehr...
18.10.2019 12:01:36
Peter
Hallo Daniel,
Code nochmals anbei:
'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
'Anfang von Daniel
With UF_AnzeigenDrucken3f.ListBox1
Worksheets("Tabelle1").Cells(10, 2).Resize(.ListCount, .ColumnCount).Value = .List
End With
'Ende von Daniel
'Ende Übertrag von ListBox1 in Tabelle1
''' Call Spaltenbreite_Zeilenhöhe_einstellen_Tabelle1 'eingebaut in Workbook_Open
'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
'Anfang von Daniel
Worksheets("Tabelle1").Range("B1:B3,C3:C4") = False
'Ende von Daniel
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 von Daniel
'Anfang Überschriften
.Range("B9:H9") = Sheets(wsName).Range("B9:H9")
'Ende Überschriften
'Ende von Daniel
'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>
Danke für Deine Hilfe.
Gruss
Peter
Anzeige
AW: Umwandeln in Zahl erledigt..
18.10.2019 12:26:17
Peter
Hallo Daniel,
ich habe jetzt das Umwandeln in Zahl für die Spalten F, G, H mit nachstehendem Code geändert:
With Worksheets("Tabelle1")
zF = .Cells(Rows.Count, 6).End(xlUp).Row
.Range("H1").Copy 'leere Zelle kopieren
.Range("F2:H" & zF).PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
.Range("F2:H" & zF).NumberFormat = "#,##0.00 $"
End With
Deutlicher Zeitgewinn von ca. 4-6 Sekunden
Hast Du noch eine Idee was geändert werden kann?
Gruss
Peter
AW: Umwandeln in Zahl erledigt..
18.10.2019 12:46:46
Daniel
Hi
suche doch mal selber die Zeitfresser.
du hast deinen Code ja schon über Kommentare in sinnvolle Abschnitte eingeteilt.
ermittle jetzt für jeden Abschnitt die Laufzeit, damit du erkennst, wo der größte Zeitfresser sitzt.
dazu legst du eine Variable vom Typ Double an und umrahmst jeden sinnvollen Abschnitt mit:
T = Timer
... hier normale Code
Debug.Print "Laufzeit Abschnitt xxx", Timer - T

damit bekommst du dann im Direktfenster eine Liste mit den Laufzeiten der einzelnen Abschnitte.
(du kannst auch statt dem Debug.Print die Messagebox verwenden, dann "fühlst" du die Laufzeit der einzelnen Abschnitte auch)
Gruß Daniel
Anzeige
AW: Umwandeln in Zahl erledigt..
19.10.2019 06:54:59
Peter
Hallo Daniel,
das mit dem Timer ist hervorragend. Hier mein Ergebnis:
Berechnung der Einzelzeit:
Laufzeit Abschnitt ListBox füllen 0,3007813 0,3007813 0,3007813
Laufzeit Abschnitt Umwandeln in Zahl 0,4550781 0,4550781 0,1542968
Laufzeit Abschnitt Kontoinhaber 1,140625 1,140625 0,6855469
Laufzeit Abschnitt Kontodaten 3,828125 3,828125 2,6875
Laufzeit Abschnitt Überschriften 3,958984 3,958984 0,130859
Laufzeit Abschnitt Übertrag Salden 5,332031 5,332031 1,373047
Laufzeit Abschnitt Spalte J u K leeren 5,462891 5,462891 0,13086
Laufzeit Abschnitt Druckvorschau 11,91602 11,91602 6,453129
GesamtZeit 11,91602
Die drei grössten Verbraucher sind Kontodaten, Salden und Druckvorschau.
Werde nun versuchen ob ich noch etwas optimieren kann - vielleicht hast Du noch eine Idee.
Gruss
Peter
Anzeige
AW: Umwandeln in Zahl erledigt..
19.10.2019 07:53:40
Daniel
Kannst du die einzelnen Abschnitte nochmal zeigen?
Formatieren sie als Code, damit die Einrückungen erhalten bleiben.
Das Seiterinrichten ist in VBA schlecht programmiert und dauert lange.
Überlege mal, ob du die Druckseite. einmalig von Hand einrichten kannst und dann do belässt.
Gruß Daniel
Weitere Optimierungen
18.10.2019 12:54:54
Daniel
hier kannst du dich auch noch austoben:
alle Zellen, die auf beiden Blättern einen lückenlosen rechteckigen zellblock bilden, können gemeinsam in einem Schritt übertragen werden, wie im Prinzip geht, hatte ich dir ja schon gezeigt:
.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")
Gruß Daniel
Anzeige
AW: sehe keine Stelle mehr...
18.10.2019 11:43:16
Peter
Hallo Daniel,
ich möchte gerade den Test durchführen. Ich finde jedoch nicht Vorgang Addieren.
Wo finde ich diesen?
Gruss
Peter
AW: sehe keine Stelle mehr...
18.10.2019 12:01:03
Daniel
Im Kontexmenü „Inhalte Einfügen“ auf der untersten Ebene, dort wo du über Optionbuttons genau auswählen kannst, was eingefügt werden soll.
Gruß Daniel
AW: sehe keine Stelle mehr...
18.10.2019 12:01:04
Daniel
Im Kontexmenü „Inhalte Einfügen“ auf der untersten Ebene, dort wo du über Optionbuttons genau auswählen kannst, was eingefügt werden soll.
Gruß Daniel
AW: sehe keine Stelle mehr...
19.10.2019 08:38:54
Peter
Hallo Daniel,
leider eine enttäuschende Nachricht von mir. Die Umwandlung in Zahlen geht nicht.
Ich verwende folgenden Code:
With Worksheets("Tabelle1")
zF = .Cells(Rows.Count, 6).End(xlUp).Row
.Range("H1").Copy 'leere Zelle kopieren
.Range("F2:H" & zF).PasteSpecial Paste:=xlPasteAll, Operation:=xlAdd, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
.Range("F2:H" & zF).NumberFormat = "#,##0.00 $"
End With
Kannst Du mir bitte mitteilen, was hier falsch ist. Besten Dank.
Gruss
Peter
Anzeige
AW: sehe keine Stelle mehr...
19.10.2019 09:22:10
Daniel
Schwer zu sagen, was da das Problem ist ohne die Daten zu kennen, weil funktionierende Makros immer durch das Zusammenspiel von Code und den dazugehörigen Daten entstehen.
Ein Problem kann sein, dass VBA oft "amerikanisch" denkt und dann Zahlenwerte mit komma nicht als Zahl erkennt.
Eine andere Methode um Text zählen in echte Zahlen umzuwandeln, ist das Ersetzen durch zuführen, weil Excel dann erneut prüft, ob Text oder Zahl vorliegt.
Dabei kann auch ein wert durch sich selbst ersetzt werden.
Beachte, dass wenn du das ausprobiert, dass in VBA die Zahlen den Dezimalpunkt brauchen und nicht das Komma um als solche erkannt zu werden.
Eine dritte Variante ist TEXT IN SPALTN.
Hier kann man ja explizit angeben, in welcher Form die Zahlen vorliegen.
Allerdings muss das Text-In-Spalten für jede Spalte einzeln durchgeführt werden.
Gruß Daniel
Anzeige
AW: jetzt wohl erledigt
19.10.2019 12:37:00
Peter
Hallo Daniel,
ich bin jetzt bei ca. 15 Sekunden. M.E. noch zu lange.
Werde noch verschiedenes ausprobieren.
Besten Dank für Deine Hilfe und ein schönes Wochenende.
Gruss
Peter

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige