Microsoft Excel

Herbers Excel/VBA-Archiv

Makro beschleunigen

Betrifft: Makro beschleunigen von: Christoph Zahn
Geschrieben am: 07.12.2015 17:29:06

Hey. Ich habe auch mal wieder eine Frage.
Habe folgendes Makro mit meinen einfachen VBA-Kenntnissen gebastelt.

Sub EndErgebnis2()
Application.DisplayAlerts = False
Dim iIndex As Integer
Do While iIndex < Sheets("Tabelle1").Range("D1")

Windows("BaywotchErstellen.xlsm").Activate
 Dim strPfad As String
 strPfad = Worksheets("Ausgangspfade").Range("D2").Value
Dim strPfad1 As String
 strPfad1 = Worksheets("Ausgangspfade").Range("D3").Value
 Dim strPfad2 As String
 strPfad2 = Worksheets("Ausgangspfade").Range("D4").Value
   Dim strDatei As String
 strDatei = Worksheets("Ausgangspfade").Range("E2").Value
Dim strDatei1 As String
 strDatei1 = Worksheets("Ausgangspfade").Range("E3").Value
 Dim strDatei2 As String
 strDatei2 = Worksheets("Ausgangspfade").Range("E4").Value
 
Application.Workbooks(strDatei).Activate


Range("C" & n + 2).Copy
Application.Workbooks(strDatei1).Activate
    Range("C999999").Select
   Selection.End(xlUp).Select
    ActiveCell.Offset(-19, 0).Select
    ActiveSheet.Paste
    
Application.Workbooks(strDatei).Activate
Range("A" & n + 2).Copy
Application.Workbooks(strDatei1).Activate
    Range("D999999").Select
   Selection.End(xlUp).Select
    ActiveCell.Offset(-19, 0).Select
    ActiveSheet.Paste
 Range(Selection, Selection.End(xlDown)).Select
    Selection.FillDown
Range("A2:D21").Select
    Selection.Copy

    
    Range("A999999").Select
        Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
n = n + 1
iIndex = iIndex + 1
Windows("BaywotchErstellen.xlsm").Activate
Loop
Application.Workbooks(strDatei1).Activate
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "100"
    Range("A3").Select
    ActiveCell.FormulaR1C1 = "=R[-1]C+1"
    Range("A3").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWindow.SmallScroll Down:=3
    Selection.FillDown
       Range("A999999").Select
        Selection.End(xlUp).Select
         ActiveCell.Offset(-19, 0).Select
    Range(Selection, Selection.End(xlToRight)).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Clear
          Dim SpeicherName2 As String
Dim Speicherpfad2 As String
Dim Speicherpfadvoll2 As String
Windows("BaywotchErstellen.xlsm").Activate
Speicherpfad2 = Sheets("Speicherpfade").Range("D3").Value 'in Zelle A1 der Tabelle1 steht der  _
Pfad z.B. C:\Test\

'aus Zelle A2 wird Name erzeugt
SpeicherName2 = Sheets("Speicherpfade").Range("E3").Value
Speicherpfadvoll2 = Speicherpfad2 & SpeicherName2
Application.Workbooks(strDatei1).Activate
ActiveWorkbook.SaveAs Filename:=Speicherpfadvoll2
        ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub

Problem ist das es bis zu 20.000 Datensätze sein können.
Würde mit dieser Variante dann um die 5 Stunden laufen. Vorausgesetzt das Makro stürzt nicht ab. Vielleicht weiß ja jemand wie man dieses Makro deutlich schneller zum laufen bringen kann.
Grundsätzlich geht es eigentlich nur um diese Schleife.
Sub EndErgebnis2()
Application.DisplayAlerts = False
Dim iIndex As Integer
Do While iIndex < Sheets("Tabelle1").Range("D1")

Windows("BaywotchErstellen.xlsm").Activate
 Dim strPfad As String
 strPfad = Worksheets("Ausgangspfade").Range("D2").Value
Dim strPfad1 As String
 strPfad1 = Worksheets("Ausgangspfade").Range("D3").Value
 Dim strPfad2 As String
 strPfad2 = Worksheets("Ausgangspfade").Range("D4").Value
   Dim strDatei As String
 strDatei = Worksheets("Ausgangspfade").Range("E2").Value
Dim strDatei1 As String
 strDatei1 = Worksheets("Ausgangspfade").Range("E3").Value
 Dim strDatei2 As String
 strDatei2 = Worksheets("Ausgangspfade").Range("E4").Value
 
Application.Workbooks(strDatei).Activate


Range("C" & n + 2).Copy
Application.Workbooks(strDatei1).Activate
    Range("C999999").Select
   Selection.End(xlUp).Select
    ActiveCell.Offset(-19, 0).Select
    ActiveSheet.Paste
    
Application.Workbooks(strDatei).Activate
Range("A" & n + 2).Copy
Application.Workbooks(strDatei1).Activate
    Range("D999999").Select
   Selection.End(xlUp).Select
    ActiveCell.Offset(-19, 0).Select
    ActiveSheet.Paste
 Range(Selection, Selection.End(xlDown)).Select
    Selection.FillDown
Range("A2:D21").Select
    Selection.Copy

    
    Range("A999999").Select
        Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste
n = n + 1
iIndex = iIndex + 1
Windows("BaywotchErstellen.xlsm").Activate
Loop

Wenn noch Erläuterungen notwendig sind einfach melden.


  

Betrifft: AW: Makro beschleunigen von: Daniel
Geschrieben am: 07.12.2015 17:58:19

Hi

1. verschiebe alles, was sich innerhalb der Schleife nicht ändert, ausserhalb dieser Schleife
die Dimensionierung der Variablen gehört grundsätzlich an den Anfang des Makros.
Die Wertzuweisung muss nur dann innerhalb der Schleife erfolgen, wenn sich die zugewiesenen Werte innerhalb der Schleife ändern können.

 Dim strPfad As String
 strPfad = Worksheets("Ausgangspfade").Range("D2").Value
Dim strPfad1 As String
 strPfad1 = Worksheets("Ausgangspfade").Range("D3").Value
 Dim strPfad2 As String
 strPfad2 = Worksheets("Ausgangspfade").Range("D4").Value
   Dim strDatei As String
 strDatei = Worksheets("Ausgangspfade").Range("E2").Value
Dim strDatei1 As String
 strDatei1 = Worksheets("Ausgangspfade").Range("E3").Value
 Dim strDatei2 As String
 strDatei2 = Worksheets("Ausgangspfade").Range("E4").Value
2. verzichte auf Selects und Activates.
die sind nicht notwendig und werden nur vom Recorder aufgezeichnet, weil wir "Mausschubser" so arbeiten müssen.
Weitere Infos dazu hier:
http://www.online-excel.de/excel/singsel_vba.php?f=78

überarbeite deinen Code mal nach diesen beiden Punkten, dann kannst du ihn hier nochmal vorstellen.
dann solltest du aber nicht nur den Code zeigen, sondern auch kurz beschreiben, was du mit dem Code erreichen willst, das erleichtert das Verständnis für dein Problem.

Gruß Daniel