Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1484to1488
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

Bearbeitung beschleunigen

Bearbeitung beschleunigen
28.03.2016 10:06:48
Tippi

Ich habe eine Tabelle mit ca.1500 Datensätzen und es dauert sehr lang bis die Bearbeitung abgeschlossen ist
Da ich kaum VBA kenntnisse habe jetzt meine Frage:
Kann man die Bearbeitung beschleunigen und den Code vereinfachen
vielen Dank im voraus

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim myRow As Long
Dim myLastRow1 As Long
Dim myLastRow2 As Long
With Sheets("Hilfstabelle")
myLastRow1 = .Cells(Rows.Count, 4).End(xlUp).Row
If myLastRow1 < 1 Then Exit Sub
End With
For myRow = 2 To myLastRow1
If Sheets("Hilfstabelle").Cells(myRow, 4).Value > 0 Then
With Sheets("Grundbuch")
myLastRow2 = .Cells(Rows.Count, 4).End(xlUp).Row
If myLastRow2 < 1 Then myLastRow2 = 11
End With
Sheets("Hilfstabelle").Rows(myRow).Copy
Sheets("Grundbuch").Rows(myLastRow2 + 1).PasteSpecial Paste:=xlValues
End If
Next myRow
With Sheets("Hilfstabelle")
myLastRow1 = .Cells(Rows.Count, 5).End(xlUp).Row
If myLastRow1 < 1 Then Exit Sub
End With
For myRow = 2 To myLastRow1
If Sheets("Hilfstabelle").Cells(myRow, 5).Value > 0 Then
With Sheets("Grundbuch")
myLastRow2 = .Cells(Rows.Count, 5).End(xlUp).Row
If myLastRow2 < 1 Then myLastRow2 = 11
End With
Sheets("Hilfstabelle").Rows(myRow).Copy
Sheets("Grundbuch").Rows(myLastRow2 + 1).PasteSpecial Paste:=xlValues
End If
Next myRow
With Sheets("Hilfstabelle")
myLastRow1 = .Cells(Rows.Count, 6).End(xlUp).Row
If myLastRow1 < 1 Then Exit Sub
End With
For myRow = 2 To myLastRow1
If Sheets("Hilfstabelle").Cells(myRow, 6).Value > 0 Then
With Sheets("Grundbuch")
myLastRow2 = .Cells(Rows.Count, 6).End(xlUp).Row
If myLastRow2 < 1 Then myLastRow2 = 11
End With
Sheets("Hilfstabelle").Rows(myRow).Copy
Sheets("Grundbuch").Rows(myLastRow2 + 1).PasteSpecial Paste:=xlValues
End If
Next myRow
MsgBox "Fertig"
Application.ScreenUpdating = True
End Sub

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bearbeitung beschleunigen
28.03.2016 10:32:42
Christoph Zahn
Hallo,
eventuell das vorweg.
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
und wieder aufheben.
dürfte bei deinem Makro nicht stören.
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
Gruß Christoph

AW: Bearbeitung beschleunigen
28.03.2016 11:19:19
Gerd L
Hallo T.!
End(xlUp).Row gibt - Fehlerwerte ausgenommen - immer mindestens den Wert 1 zurück.
Eine Prüfung auf < 1 ist daher entbehrlich.
Die Ausgabe im Zielblatt erfolgt je Spaltenermittlung in einen Block.
Filtern u. Verwendung eines Datenfeldes als Zwischenspeicher sind im Normalfall schneller.
Private Sub CommandButton1_Click()
Dim myRow As Long
Dim myLastRow1 As Long
Dim myLastRow2 As Long
Dim Col As Long
Dim rngCopyRows As Range
For Col = 4 To 6
myLastRow2 = Sheets("Grundbuch").Cells(Sheets("Grundbuch").Rows.Count, Col).End(xlUp).Row
If myLastRow2 < 11 Then myLastRow2 = 11
With Sheets("Hilfstabelle")
For myRow = 2 To Application.Max(2, .Cells(.Rows.Count, Col).End(xlUp).Row)
If .Cells(myRow, Col).Value > 0 Then
If rngCopyRows Is Nothing Then
Set rngCopyRows = .Rows(myRow)
Else
Set rngCopyRows = Union(rngCopyRows, .Rows(myRow))
End If
myLastRow2 = myLastRow2 + 1
End If
Next myRow
If Not rngCopyRows Is Nothing Then
rngCopyRows.Copy
Sheets("Grundbuch").Rows(myLastRow2 + 1).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Set rngCopyRows = Nothing
End If
End With
Next Col
MsgBox "Fertig"
End Sub
Gruß Gerd

Anzeige
AW: Bearbeitung beschleunigen
28.03.2016 19:43:17
Tippi
Hallo Gerd
erstmal herzlichen Dank für deine Antwort
dein Code ist echt super schnell und funktionert auch soweit ganz gut nur beim einfügen lässt er immer 12 Zeilen frei wenn ein neuer Datensatz dazu kommt und die letzte kopierte Zeiele wird doppelt wieder gegeben.
Was muss ich ändern das fortlaufend und ohne leere Zeilen eingefügt wird.
Hier ein Beispiel wie eingefügt wird:
4009208000283 10
4014607000307 11
4009208000351 12
4009208000429 14
4009208000443 16
4009208000474 2587412
4009208000474 2587412
4014607000048 2
4009208000054 3
4009208000061 4
4009208000108 6
4009208000115 7
4009208000139 8
4009208000283 10
4014607000307 11
4009208000351 12
4009208000429 14
4009208000443 16
4009208000474 2587412
4009208000474 2587412

Anzeige
AW: Bearbeitung beschleunigen
28.03.2016 20:39:20
Gerd L
Hallo T.,
ich habe keine Beispieldatei. Schaue, ob es so besser läuft. Die letzte Zeile wird jetzt immer in Spalte D von "Grundbuch" ermittelt u. der Zeilenzähler im Zielblatt myLastRow2 wurde korrigiert.
Private Sub CommandButton1_Click()
Dim myRow As Long
Dim myLastRow1 As Long
Dim myLastRow2 As Long
Dim Col As Long
Dim rngCopyRows As Range
For Col = 4 To 6
myLastRow2 = Sheets("Grundbuch").Cells(Sheets("Grundbuch").Rows.Count, 4).End(xlUp).Row
If myLastRow2 < 11 Then myLastRow2 = 11
With Sheets("Hilfstabelle")
For myRow = 2 To Application.Max(2, .Cells(.Rows.Count, Col).End(xlUp).Row)
If .Cells(myRow, Col).Value > 0 Then
If rngCopyRows Is Nothing Then
Set rngCopyRows = .Rows(myRow)
Else
Set rngCopyRows = Union(rngCopyRows, .Rows(myRow))
End If
myLastRow2 = myLastRow2 + 1
End If
Next myRow
If Not rngCopyRows Is Nothing Then
rngCopyRows.Copy
Sheets("Grundbuch").Rows(myLastRow2).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Set rngCopyRows = Nothing
End If
End With
Next Col
MsgBox "Fertig"
End Sub
Gruß Gerd

Anzeige
AW: Bearbeitung beschleunigen
29.03.2016 21:41:57
Tippi
Hallo Gerd
erstmal wieder herzlichen Dank für deine Mühe
Leider funktionert der Code noch nicht so richtig
Ich habe mal eine Test-Datei hochgeladen
https://www.herber.de/bbs/user/104656.xlsm

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige