Live-Forum - Die aktuellen Beiträge
Datum
Titel
25.04.2024 23:47:55
Datum ausweisen, wenn definierte Summe erreicht ist
25.04.2024 21:40:53
Excel Datenquelle aus dem Web mit Anmeldung?
25.04.2024 21:21:16
Zellkommentar in UserForm anzeigen und bearbeiten
25.04.2024 21:13:13
Kalenderwochen addieren
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1744to1748
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1744to1748
1744to1748
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Code ist extrem langsam

Code ist extrem langsam
05.03.2020 16:37:28
Peter
Hallo,
ich habe eine extrem grosse Excel-Datei. Diese Datei zu übermitteln ist aufgrund der Grösse nicht möglich.
Mit der UF wird ein Datum-Bereich ausgewählt und anhand dieser Datumsdaten wird die ListBox1 befüllt.
Ein Code zum Befüllen von drei Möglichkeiten ist:
'Auswahl anzeigen Datum
Private Sub CommandButton17_Click()
Dim i As Long, maxlen As Long, Li As Long, ii As Long, LC As Long
Dim str As String, str2 As String, arr As Variant
Dim Startdatum As Date, EndDatum As Date
Dim wsName As String
Dim Kat As String
wsName = Me.ComboBox3.Value
Worksheets(wsName).Activate
'geändert auf CDate(UserForm4.tbx_Startdatum)
'in einer Textbox steht Text der wird mit
'CDate in ein Datum gewandelt
Startdatum = CDate(Me.TextBox2)
EndDatum = CDate(Me.TextBox3)
Kat = Me.TextBox1
maxlen = 35
With ListBox1
.Clear
.ColumnCount = 10
.ColumnWidths = "3cm;6cm;3cm;3cm;3cm;3cm;0cm;0cm;0cm;0cm"  'Spalte 6 Bestand wird  _
ausgeblendet
'hier geändert von i=9 auf i=10 (ohne die Kopfzeilen)
'Spaltenbeschriftung über Label
'''    For i = 10 To Cells(Rows.Count, "B").End(xlUp).Row
For i = 11 To Cells(Rows.Count, "B").End(xlUp).Row          '11=ohne Saldozeile
'    For i = 12 To Cells(Rows.Count, "B").End(xlUp).Row          '12=ohne Saldozeile
Li = i - 9
'''        Li = i - 10
str = Cells(i, 3)
If CDate(Cells(i, 2)) >= Startdatum And CDate(Cells(i, 2))  9 Then
If str = "" Then str = " "
arr = Split(str, " ")
str2 = arr(0)
For ii = 1 To UBound(arr)
If Len(str2 & arr(ii)) + 1  "" Then
intSum1 = intSum1 + .List(i, 4)
End If
Next
End With
Label6 = intSum1
Label6 = Format(Label6, "#,##0.00 €")
'Summe Spalte4=SpalteF=Ausgaben
With ListBox1
For i = 0 To .ListCount - 1
If .List(i, 5) > "" Then
intSum2 = intSum2 + .List(i, 5)
End If
Next
End With
Label7 = intSum2
Label7 = Format(Label7, "#,##0.00 €")
'Summe Einnahmen ./. Ausgaben in Label8
Label8 = Label6 - Label7
Label8 = Format(Label8, "#,##0.00 €")
'Anfang Anfangbestand und Endbestand in jeweils ausgewähltem Bereich
With ListBox1
If ListBox1.ListCount > 0 Then
Label18 = (.List(0, 6))
Label18 = Format(Label18, "#,##0.00 €")
Label19 = (.List(0, 4))
Label19 = Format(Label19, "#,##0.00 €")
Label20 = (.List(0, 5))
Label20 = Format(Label20, "#,##0.00 €")
Label21 = CDbl(Label18) - CDbl(Label19) + CDbl(Label20)
Label21 = Format(Label21, "#,##0.00 €")
Label22 = CDbl(Label21) + CDbl(Label6) - CDbl(Label7)
Label22 = Format(Label22, "#,##0.00 €")
End If
End With
'Ende Anfangbestand und Endbestand in jeweils ausgewähltem Bereich
If ListBox1.ListCount > 0 Then
'CommandButton28.Enabled = True
CommandButton3.Enabled = True
End If
End Sub
Das Auslesen der gesuchten Daten im Formular wird dann mit dem nachfolgenden Code und weiteren Daten in die Tabelle1 übertragen:
'Werte übertragen für Druckvorschau schnell
Private Sub CommandButton31_Click()
Dim lngLetzte As Long   'benötigt für letzte beschriebene Zelle - löschen von Tabelle1
'    'Anfang Dim für Kontoinhaber übertragen
Dim SuchDatumA As Date      'benötigt für Übertrag der Daten von Tabelle: Kontoinhaber
Dim SearchFor As Object     'benötigt für Übertrag der Daten von Tabelle: Kontoinhaber
'    'Ende Dim für Kontoinhaber übertragen
Dim wsName As String    'benötigt für Kontodaten und Überschriften
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
With Worksheets("Tabelle1")
lngLetzte = .Cells(Rows.Count, 7).End(xlUp).Row  'wählt die letzte, beschriebene Zelle  _
von unten
.Range("A1:M" & lngLetzte).Clear
End With
'Anfang für Kontoinhaber übertragen
SuchDatumA = Me.TextBox2 'Worksheets("Kontoinhaber").Cells(3, 16)
Set SearchFor = Worksheets("Kontoinhaber").Cells(WorksheetFunction.Match(CLng(SuchDatumA),  _
Worksheets("Kontoinhaber").Columns(6), 1), 6)
With Worksheets("Kontoinhaber")
Worksheets("Tabelle1").Range("B1") = .Cells(SearchFor.Row, 1)       'Inhaber_Name
Worksheets("Tabelle1").Range("B2") = .Cells(SearchFor.Row, 2)       'Inhaber_Strasse
Worksheets("Tabelle1").Range("B3") = .Cells(SearchFor.Row, 3)       'Inhaber_PLZ
Worksheets("Tabelle1").Range("C3") = .Cells(SearchFor.Row, 4)       'Inhabere_Ort
Worksheets("Tabelle1").Range("C4") = 0 & .Cells(SearchFor.Row, 5)   '0 & Inhaber_Tel
End With
'Ende für Kontoinhaber übertragen
'!Übertrag Kontoinhaber funktioniert
'Anfang Kontodaten übertragen
wsName = Me.ComboBox3.Value 'übernimmt Kontoname für Kontoinhaber übertragen
With Worksheets("Tabelle1")
.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 Kontodaten übertragen
'Anfang Überschriften übertragen
.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 übertragen
'!Übertrag Kontodaten und Überschriften funktioniert
'Anfang Übertrag von ListBox1 in Tabelle1
With Worksheets("Tabelle1")
With 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
End With
'Ende Übertrag von ListBox1 in 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 Übertrag der Salden
.Range("B65536").End(xlUp).Offset(2, 3) = "Anfangsaldo der Auswahl" '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) = "Summe Einnahmen der Auswahl" '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) = "Summe Ausgabe der Auswahl" '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) = "Ges.- Einnahmen - Ges.- Ausgaben" '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) = "Endsaldo der Auswahl" '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
End With
End Sub
Und zum Schluss wird mittels dem nachfolgenden Code die Druckvorschau geöffnet:
'Druckvorschau Test - schnell
Private Sub CommandButton30_Click()
Dim lngLetzte As Long   'benötigt für letzte beschriebene Zelle
Me.Hide
With Worksheets("Tabelle1")
lngLetzte = .Cells(Rows.Count, 7).End(xlUp).Row  'wählt die letzte, beschriebene Zelle  _
von unten
'Anfang - Seite_einrichten Makro
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintArea = "$B$1:$H$" & lngLetzte
.PrintTitleRows = "$1:$9"
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.590551181102362)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.75)
.BottomMargin = Application.InchesToPoints(0.75)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.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 = 75
End With
'Ende - Seite_einrichten Makro
.PrintPreview
Me.Show
End With
End Sub
Insgesamt dauert diese Prozedur ca. 2-3 Minuten, wobei die Tabelle1 nur mit 74 Zeilen gefüllt ist. Es können auch ca. 600 werden.
Könnt ihr mir bitte helfen, dass der zweite Code zum Befüllen der Tabelle1 deutlich schneller wird.
Besten Dank
Gruss
Peter

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Pack die Daten in eine Variant-Variable ...
05.03.2020 18:22:33
lupo1
... und das ganze läuft 100- bis 1000-mal so schnell.
Am Ende schreibt man das ganze in einer einzigen Zuweisung als Block zurück in die Tabelle(n).
AW: Pack die Daten in eine Variant-Variable ...
06.03.2020 07:13:45
Peter
Hallo Lupo1,
vielen Dank für Deinen Hinweis.
Damit kenne ich mich jedoch nicht aus und habe auch keine richtige Anweisung gefunden.
Kannst Du mir hierbei bitte behilflich sein.
Gruss
Peter
Hier ein Beispiel (Code ganz unten)
06.03.2020 16:27:44
lupo1
http://xxcl.de/0052.htm
Der Nachteil der Verlagerung der Tabelle in einen Variant ist (für einige), dass man nach Programmiersprachenlogik vorgeht, nicht nach Excel-Menü-Logik.
Außerdem erlaubt der Variant nur die Behandlung von .Value. Alle anderen Eigenschaften muss man hingegen in der Tabelle zuweisen.
Anzeige
AW: erledigt
06.03.2020 19:54:19
Peter
Hallo Lupo,
besten Dank für Deine Hilfe.
Ich habe mich jedoch zu einer Variante entschieden in einer Mischung aus den Codes von Thorsten und Daniel.
Wünsche Dir noch ein schönes Wochenende.
Gruss
Peter
AW: Code ist extrem langsam
06.03.2020 07:49:55
Oberschlumpf
Hi Peter,
dass deine Originaldatei zu groß ist, glaube ich.
Aber trotzdem könntest du - per Upload - eine stark verkleinerte Datei mit Bsp-Daten UND deinem Code/Userforms zur Verfügung stellen.
Natürlich muss die Bsp-Datei vom Aufbau (gleiche Spaltenverwendung + sonstiges) genau so sein, wie das Original.
Ja, ich weiß, eine stark verkleinerte Datei wird bestimmt schneller mit deinem Code befüllt, als das Original - und trotzdem hätte zumindest ich gern eine Bsp-Datei von dir, weil zumindest ihc keine Lust habe, eine Datei nachbauen zu müssen, was, so denke ich, erfrorderlich ist bei der Menge des Codes, den du hier zeigst.
Ciao
Thorsten
Anzeige
AW: Code ist extrem langsam
06.03.2020 09:49:18
Peter
Hallo Thorsten,
ich habe nun die Datei in den für diesen Zweck erforderlichen Bereich umgebaut.
Kurze Erläuterung:
Öffne bitte die vorhandene Userform, wähle dort unter 2. das vorherige Datum 01.08.2019-31.07.2020 aus.
Drücke dann den Button "Daten anzeigen entsprechend Auswahl". Damit wird die ListBox1 gefüllt.
Mit dem Button "Werte übertragen" werden die Daten in die Tabelle1 übertragen.
Mit dem Button "Druckvorschau schnell" wird die Druckvorschau angezeigt mit den Werten aus der Tabelle1.
https://www.herber.de/bbs/user/135654.xlsm
Besten Dank für Deine Hilfe.
Gruss
Peter
Anzeige
Geduld haben lohnt sich :-)
06.03.2020 15:35:18
Oberschlumpf
Hi Peter,
...oh, ich sehe gerade, auch Daniel hat schon geantwortet.
Na, vielleicht kannst du mit seinen Code-Beispielen ja meinen Code noch zusätzlich verbessern :-)
hier meine Datei
https://www.herber.de/bbs/user/135671.xlsm
Auch ich habe vieles mit viel weniger Code durchgeführt, weil, wie Daniel schon beschrieb, es schneller geht, wenn man am besten Zellbereichsweise (Blockweise), oder wenigstens zeilenweise, aber möglichst nicht ZELLE für ZELLE mit Werten füllt.
Für Testzwecke habe ich anstelle deiner ca 80 Datenzeilen fast 1440 Datenzeilen eingesetzt.
Mein Computer benötigt mit deinem Code ca 8 Sekunden.
Mein Computer benötigt mit meinem Code ca 1 Sekunde. :-)
Dass mein PC viel schneller als deiner ist (600 Zeilen in 2-3 Minuten), mag daran liegen, weil ich einen HighEnd-Computer nutze. (aber das nur nebenbei)
Wenn man diesen Geschwindigkeitsvorteil (aus 8 mach 1) auf deinen PC überträgt, dann müsste dein PC bei 600 Datenzeilen doch nur noch ca 23 Sekunden benötigen - DAS wär doch auch schon was, oder? ;-)
Na ja, ich habe nur den Code für den Button "Werte übertragen" geändert.
Und in meinem Code findest du auch einige Kommentarzeilen, die meinen Code hoffentlich verständlich erklären.
Ich hab auch wegen der Zeitmessung Code eingefügt, den du wieder löschen kannst. Diesen Zeilen habe ich kommentiert mit "kannst du löschen" oder so ähnlich.
Deinen alten Code habe ich erst mal stehen gelassen. Auch den kannst du löschen, wenn du mit meinem Code zufrieden bist.
So, puhh, ich hab doch n paar Std für dich "gebraucht" :-) Wenn ich noch etwas vergessen habe, frag einfach.
Konnte ich denn helfen?
(eine Antwort wäre schön)
Ciao
Thorsten
Anzeige
AW: erledigt
06.03.2020 20:07:38
Peter
Hallo Thorsten,
vielen Dank für Deine Hilfe. Es tut mir leid, dass du hierfür so lange benötigt hast. Aber der Erfolg ist hervorragend.
Ich habe deine Lösung mit einem Teil von Daniel ergänzt. In Hinblick auf die Umwandlung Text in Zahl habe ich das Format geändert.
Der nachfolgende Code funktioniert einwandfrei:
Private Sub CommandButton32_Click()
Dim lngLetzte As Long   'benötigt für letzte beschriebene Zelle - löschen von Tabelle1
Dim ldtStart As Date, ldtEnde As Date 'kannst du wieder löschen; benötige ich zum Messen  _
der benötigten Zeit
'benötigte Zeit mit deinem jetzigen Code und Übertragen von 1439 Zeilen nach Tabelle1 = 8  _
Sekunden
'benötigte Zeit mit meinem Code und Übertragen von 1439 Zeilen nach Tabelle1 = 1 Sekunde ! : _
-)
'das es bei dir mit ca 600 Zeilen = ca 2-3 Minuten dauert und bei mir mit ca 1600 Zeilen  _
nur ca 8 Sekunden dauert, kann daran liegen, dass ich einen viel schnelleren PC habe (mein PC hat Intel I7 Prozessor, 32 GB RAM und noch so einiges aus der Hardware-"Oberliga"; dafür hab ich aber NUR einen 23"-Monitor) :-)
'Anfang Dim für Kontoinhaber übertragen
Dim SuchDatumA As Date      'benötigt für Übertrag der Daten von Tabelle: Kontoinhaber
Dim SearchFor As Object     'benötigt für Übertrag der Daten von Tabelle: Kontoinhaber
'Ende Dim für Kontoinhaber übertragen
Dim wsName As String    'benötigt für Kontodaten und Überschriften
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 zJ As String     'benötigt für letzte beschriebene Zelle in Spalte J
ldtStart = Time 'kann gelöscht werden; benötige ich nur für Zeitermittlung, wie lange das  _
Makro dauert, bis es fertig ist
With Worksheets("Tabelle1")
lngLetzte = .Cells(Rows.Count, 7).End(xlUp).Row  'wählt die letzte, beschriebene Zelle  _
von unten
.Range("A1:M" & lngLetzte).Clear
End With
'Anfang für Kontoinhaber übertragen
SuchDatumA = Me.TextBox2 'Worksheets("Kontoinhaber").Cells(3, 16)
Set SearchFor = Worksheets("Kontoinhaber").Cells(WorksheetFunction.Match(CLng(SuchDatumA),  _
Worksheets("Kontoinhaber").Columns(6), 1), 6)
With Worksheets("Kontoinhaber")
Worksheets("Tabelle1").Range("B1") = .Cells(SearchFor.Row, 1)       'Inhaber_Name
Worksheets("Tabelle1").Range("B2") = .Cells(SearchFor.Row, 2)       'Inhaber_Strasse
Worksheets("Tabelle1").Range("B3") = .Cells(SearchFor.Row, 3)       'Inhaber_PLZ
Worksheets("Tabelle1").Range("C3") = .Cells(SearchFor.Row, 4)       'Inhabere_Ort
Worksheets("Tabelle1").Range("C4") = 0 & .Cells(SearchFor.Row, 5)   '0 & Inhaber_Tel
End With
'Ende für Kontoinhaber übertragen
'Anfang Kontodaten übertragen
wsName = Me.ComboBox3.Value 'übernimmt Kontoname für Kontoinhaber übertragen
With Worksheets("Tabelle1")
.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 Kontodaten übertragen
'Anfang Überschriften übertragen
.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 übertragen
End With
'Anfang Übertrag von ListBox1 in Tabelle1
With ListBox1
Worksheets("Tabelle1").Cells(10, 2).Resize(.ListCount, .ColumnCount) = .List
End With
'Ende Übertrag von ListBox1 in Tabelle1
'Anfang Umwandlung von Zahl in Währung
With Worksheets("Tabelle1") 'Codezeile 1 von Umwandlung
'in Spalte F,G+H werden die Texte in Spalten verteilt; da nur 1x "Text" (dein  _
Zahlenwert mit €-Zeichen), wird dieser "Text" in Zahl umgewandelt
'leider ist das Format dann ".000 €" (ich weiß nicht warum), als Zahl z Bsp "4.000 €"  _
und nicht "4,00 €", oder ".000 €" und nicht "0,00 €"
.Range("F10:F" & .Cells(Rows.Count, 6).End(xlUp).Row).TextToColumns Destination:=.Range( _
"F10")
'deswegen wird mit der nächsten Codezeile das Format wieder in "0,00 €" geändert
.Range("F10:F" & .Cells(Rows.Count, 6).End(xlUp).Row).NumberFormat = "#,##0.00 €"
.Range("G10:G" & .Cells(Rows.Count, 7).End(xlUp).Row).TextToColumns Destination:=.Range( _
"G10")
.Range("G10:G" & .Cells(Rows.Count, 7).End(xlUp).Row).NumberFormat = "#,##0.00 €"
.Range("H10:H" & .Cells(Rows.Count, 8).End(xlUp).Row).TextToColumns Destination:=.Range( _
"H10")
.Range("H10:H" & .Cells(Rows.Count, 8).End(xlUp).Row).NumberFormat = "#,##0.00 €"
End With 'Codezeile 8 (ohne Kommentar- +Leerzeilen) von Umwandlung :-) - du hast 41  _
Codezeilen gebraucht (ohne Leerzeilen) :-))))
'Ende Umwandlung von Zahl in Währung
'Anfang Übertrag der Salden
With Worksheets("Tabelle1")
.Range("B65536").End(xlUp).Offset(2, 3) = "Anfangsaldo der Auswahl" '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) = "Summe Einnahmen der Auswahl" '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) = "Summe Ausgabe der Auswahl" '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) = "Ges.- Einnahmen - Ges.- Ausgaben" '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) = "Endsaldo der Auswahl" 'Me.Label27"
.Range("B65536").End(xlUp).Offset(3, 6) = CDbl(Me.Label22)
.Range("B65536").End(xlUp).Offset(3, 6).NumberFormat = "#,##0.00 €"
End With
'Ende Übertrag der Salden
'Anfang Spalte J u K leeren - wegen Drucken
With Worksheets("Tabelle1")
zJ = .Cells(Rows.Count, 10).End(xlUp).Row
.Range("J2:K" & zJ).Clear
End With
'Ende Spalte J u K leeren - wegen Drucken
ldtEnde = Time 'kann gelöscht werden; wird für Zeitermittlung benötigt
MsgBox ldtStart & vbCrLf & ldtEnde & vbCrLf & Format(ldtEnde - ldtStart, "hh:mm:ss") 'kann  _
gelöscht werden; zeigt die Start/Ende-Zeit des Makros und Unterschied zwischen Start + Ende
End Sub
Nochmals vielen Dank und ein schönes Wochenende.
Gruss
Peter
Anzeige
AW: erledigt
06.03.2020 20:13:18
Oberschlumpf
Hi Peter,
schön, freut mich, dass ich helfen konnte.
Und ja, der neue Code für 'Anfang Übertrag von ListBox1 in Tabelle1 ist noch eleganter als mein Code.
Kannst du mir bitte noch verraten, wie viel Zeit dein PC nun für ca 600 Datenzeilen, oder sogar für meine ca 1500 Datenzeilen benötigt?
Aus mehreren Minuten müssten doch auch Sekunden geworden sein, oder?
Ciao
Thorsten
AW: erledigt
06.03.2020 20:26:02
Peter
Hallo Thorsten,
natürlich kann ich Dir das mitteilen:
Zwischen 0 und 1 Sekunde für die von Dir eingetragenen 1450 Zeilen.
Absolute Spitze - ich bin wirklich begeistert.
Gruss
Peter
Anzeige
AW: Code ist extrem langsam
06.03.2020 14:42:36
Daniel
Hi
eine Grundregel in VBA ist, das man Zellen möglichst nicht einzeln bearbeitet, sondern als block in einem Schritt.
immer dann, wenn man mehrere Zellen, die einen rechteckigen Block bilden, auf die gleiche weise bearbeitet, sollte man prüfen, ob das möglich ist.
beispielsweise wird 
    'Anfang Überschriften übertragen
.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 übertragen

so verkürzt zu 
    'Anfang Überschriften übertragen
.Range("B9:H9") = Sheets(wsName).Range("B9:H9")
'Ende Überschriften übertragen

das wird dann auch wesentlich schneller ausgeführt als die einzelbearbeitung.
dieses Prinzip kannst du noch an weiteren Stellen im Code verwenden.
auch der Listboxinhalt lässt sich in einem Schritt übertragen, wenn dies 1:1 passiert, ohne Änderung.
aus der schleife 

For i = 0 To .ListCount - 1
For j = 0 To .ColumnCount - 1
Worksheets("Tabelle1").Cells(i + 10, j + 2) = .List(i, j)
Next
Next

wird in einem Schritt: 
Worksheets("Tabelle1").Cells(10, 2).resize(.listcount, .columncount) = .List

auch das umwandeln von Textzahlen in echte Zahlen kann für alle zellen in einem schritt erfolgen, in
dem man eine leere Zelle kopiert und in den betroffenen Zellbereich einfügt mit dem Vorgang "addieren".
sieht in VBA etwa so aus: 
cells(1, 10000).copy
range("?").pastespecial xlpastevalues, Operator:=xladd

allerdings sollTe man hier prüfen, ob Dezimalzahlen korrekt umgewandelt werden.
weitere Methoden, um Textzahlen in echteZahlen zu wandeln wäre TEXT IN SPALTEN, dieses muss aber für jede Spalte einzeln angewendet werden. bei Dezimalzahlen muss man explizit das Dezimalzeichen angeben, damit die UmwANDLUNG korrekt erfolgt. (den notwendigen Code zeigt dir der Recorder)
die dritte Methode wäre, dass du das Dezimalzeichen der texzahlen durch den Punkt ersetzt. _ Innerhalb von VBA muss ein Text, der in eine Zahl gewndelt werden soll, dem amerikanischen Format entsprechen 

Range("..").replace ",", ".", xlpart

gruß Daniel
Anzeige

Links zu Excel-Dialogen

TextBox UserForm

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige