Code wird langsam zu langsam! :)

[cysu11]

Hallo liebe Excelgemeinde,


habe folgenden Code gebastelt um Rechnungsdaten zu importieren:

Code:

Private Sub Rechnungsprüfung()
wahl = MsgBox("Neue Rechnungsdaten importieren?", vbYesNo)
If wahl <> 6 Then Exit Sub
Dim loZeile1 As Long, loZeile2 As Long
Dim Datei As Object
Dim Wert1 As String
Dim Wert2 As String
Dim Wert3 As String
Dim WS As Worksheet
Dim WS2 As Worksheet
Dim neueDatei As String
Dim NameOhneXLSX As String
  Dateiname = Application.GetOpenFilename("Excel Datei, *.*") ' Datei auswählen
   If Dateiname = "Falsch" Then Exit Sub ' bei Abbruch
   Application.ScreenUpdating = True
  Dim var
     var = MsgBox("Import der Rechnungsdaten starten? ", vbYesNo)
     If var = 7 Then
        Exit Sub
     Else
   Set Datei = Workbooks.Open(Dateiname) ' Datei öffnen
Set WS = Workbooks(ActiveWorkbook.Name).Worksheets(1)
loZeile1 = WS.Cells(Rows.Count, 2).End(xlUp).Row
Workbooks("Rechnungen2016.xlsm").Activate
Set WS2 = Workbooks(ActiveWorkbook.Name).Worksheets(1)
loZeile2 = WS2.Cells(Rows.Count, 2).End(xlUp).Row

For i = 6 To loZeile1
Wert1 = WS.Range("K" & i).Value
Wert3 = WS.Range("AZ" & i).Value
Wert4 = WS.Range("B" & i).Value
Wert5 = WS.Range("Y" & i).Value
Wert6 = WS.Range("AJ" & i).Value
Wert7 = WS.Range("D" & i).Value
Wert8 = WS.Range("J" & i).Value & "/" & WS.Range("K" & i).Value
Wert9 = WS.Range("W" & i).Value & " / " & WS.Range("X" & i).Value & " / " & WS.Range("AB" & i).Value
Wert10 = WS.Range("J" & i).Value & "/" & WS.Range("K" & i).Value
Wert12 = WS.Range("R" & i).Value & " * " & WS.Range("T" & i).Value & " * " & WS.Range("U" & i).Value
booGefunden = False
For k = 8 To loZeile2
Wert2 = WS2.Range("B" & k).Value
Wert11 = ThisWorkbook.Sheets("Diverse").Range("B" & k).Value
If Wert1 = Wert2 Then
WS2.Range("G" & k).Cells.Activate
ActiveWindow.ScrollRow = ActiveWindow.ActiveCell.Row
ActiveWindow.SmallScroll Down:=-20
WS2.Range("G" & k).Value = CDbl(Wert3)
WS2.Range("I" & k).Value = Wert4
WS2.Range("B" & k).Formula = "85/" & WS2.Range("B" & k)
booGefunden = True
Else
If Wert10 = Wert2 Or Wert10 = Wert11 Then

wahl = MsgBox("Rechnungsdaten zur Sendung " & Wert10 & " bereits vorhanden! Nächste Sendung?", vbYesNo)
If wahl <> 6 Then Exit Sub


'MsgBox "Rechnungsdaten zur Sendung " & Wert10 & " bereits vorhanden!"
booGefunden = True
Exit For
End If

End If
Next k
If booGefunden = False Then

Sheets("Diverse").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert9
Range("B65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert8
Range("C65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert5
Range("D65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert6
Range("E65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert7
Range("F65536").End(xlUp).Offset(1, 0).Select
Selection.Value = CDbl(Wert3)
Range("G65536").End(xlUp).Offset(1, 0).Select
Selection.Value = CDbl(Wert3)
Range("I65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert4
Application.ScreenUpdating = False
AufhebenTemp
Application.ScreenUpdating = True
With ActiveCell
   Range(Cells(.Row, 1), Cells(.Row, 9)).Select
   Selection.Interior.ColorIndex = 6
End With

wahl = MsgBox("Sendung " & Wert10 & " * " & Wert12 & " nicht gefunden! Sendung OK?", vbYesNo)
If wahl <> 6 Then
With ActiveCell
   Range(Cells(.Row, 1), Cells(.Row, 9)).Select
   Selection.Interior.ColorIndex = xlNone
End With

ActiveCell.EntireRow.ClearContents
BlattSchutz
MsgBox "Sendung " & Wert10 & " gelöscht!"
End If
AufhebenTemp
With ActiveCell
   Range(Cells(.Row, 1), Cells(.Row, 9)).Select
   Selection.Interior.ColorIndex = xlNone
End With
BlattSchutz

'MsgBox "Sendung " & Wert10 & " nicht gefunden! Bitte prüfen!"
Sheets("Versand").Select
End If
Next i
neueDatei = Datei.Path & "\" & Datei.Name ' Datei.Path & "\" &
NameOhneXLSX = Left(neueDatei, Len(neueDatei) - 5)
Datei.Close SaveChanges:=False
Name neueDatei As NameOhneXLSX & " - " & Format(Now, "yyyy_mm_dd_hhmm") & ".xlsx"
MsgBox ("Import Rechnungsdaten abgeschlossen!")
End If
Worksheets("Versand").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Worksheets("Diverse").Select
Range("A65536").End(xlUp).Offset(1, 0).Select

ThisWorkbook.Activate
Call Aktualisieren
End Sub

Dieser funktoniert prima und macht genau das was er soll, allerdings je mehr DAtensätze ich habe umso länger benötigt der Code um dies durchzulaufen!
Kann mir jemand helfen um diesen schneller zu machen?
Vielen Dank
VG
Alexandra

[schauan]

Hallo Alexandra,

erst mal nur der Hinweis, dass es schneller geht, wenn Du nicht jede Zelle einzeln bearbeitest, sondern mit Arrays arbeitest. Du kannst z.B. die Daten der Spalten in ein oder mehrere Arrays übernehmen, dort Deine Berechnungen vornehmen undggf. mit den Ergebnissen weitere Arrays füllen, und das oder die Ergebnisarrays dann in die Tabelle eintragen.

Im Prinzip so, schaue es Dir mal auf einem leeren Blatt an:

Code:

Sub Makro1()
    'Zahlen eintragen
    Cells(1, 1) = "1"
    Cells(2, 1) = "2"
    Cells(3, 1) = "3"
    'Bereich aus SPalte A in Array uebernehmen
    arrBereich = Range("A1:A3")
    'Werte im Array multiplizieren
    For i = 1 To 3
      arrBereich(i, 1) = arrBereich(i, 1) * 2
    Next
    'Array in Spalte B zurueckschreiben
    Range("B1:B3") = arrBereich
End Sub

[cysu11]

Hallo Andre,


danke für den Hinweis! Dein Code habe ich mal so getestet un es geht natürlich schnell!
Kannst du mir zeigen wie und wo muss ich diesen einbauen in meinen Code, damit dieser genauso schnell ist? :)


Vielen Dank im Voraus
LG
Alexandra

[cysu11]

Hallo zusammen,


kann mir vielleicht jemand helfen damit mein Code schneller wird?


Vielen Dank im Voraus
LG
Alexandra

[snb]

Etwas zum Lesen:

http://www.snb-vba.eu/VBA_Arrays_en.html

[schauan]

Hallo Alexandra,

Dein erstes Array könnte z.B so sein:
arr1 = Range("B6:AZ" & lozeile1)
For i=1 to lozeile1-5
Wert1=arr1(i,10)
...

[schauan]

Hallo Alexandra,
Bin derzeit etwas eingeschränkt und daher hab ich nur ab und zu einen "oberflächlichen" Tipp.
Den Code, wo Du ws2...Range("G" & k) aktivierst und dann 2x scrollst kannst Du weglassen.
Weiter unten tust Du Zellen selektieren und jeweils eine Zeile später einen Wert übernehmen Das kannst Du jeweils zu einer Zeile zusammenstellen ohne select und selection...

[cysu11]

Hallo Andre,


ich bin ganz ehrlich, ich habe keine Ahnung wo ich das einfügen/ersetzten muss! :( :22:
Evtl. kannst du mir den Code entsprechend ändern!? (wenn du wieder mal mehr Zeit und natürlich Lust hast) oder auch vielleicht jemand anderes!?


Für eure Hilfe vielen Dank im Voraus
LG
Alexandra

[schauan]

Hallo Alexandra,

Diesen Teil:

Code:

Wert1 = WS.Range("K" & i).Value
Wert3 = WS.Range("AZ" & i).Value
Wert4 = WS.Range("B" & i).Value
Wert5 = WS.Range("Y" & i).Value
Wert6 = WS.Range("AJ" & i).Value
Wert7 = WS.Range("D" & i).Value
Wert8 = WS.Range("J" & i).Value & "/" & WS.Range("K" & i).Value
Wert9 = WS.Range("W" & i).Value & " / " & WS.Range("X" & i).Value & " / " & WS.Range("AB" & i).Value
Wert10 = WS.Range("J" & i).Value & "/" & WS.Range("K" & i).Value
Wert12 = WS.Range("R" & i).Value & " * " & WS.Range("T" & i).Value & " * " & WS.Range("U" & i).Value

kürzt Du ab:

Code:

arrDaten=Ws.Range("B6:AZ" & loZeile1)
For i=1 to LoZeile1-5
Wert1=arrdaten(i,10) 'Fuer Ki
...

Da das Array mit 1 beginnt und nicht mit 6 ist hier die Schleifenbegrenzung entsprechend "verschoben" Für die Wertzuweisungen greifst Du dann also nicht mehr auf die Zellen zu, sondern die Felder des Arrays.

Du hast weiter unten diesen code:

Code:

Sheets("Diverse").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert9
Range("B65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert8
Range("C65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert5
Range("D65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert6
Range("E65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert7
Range("F65536").End(xlUp).Offset(1, 0).Select
Selection.Value = CDbl(Wert3)
Range("G65536").End(xlUp).Offset(1, 0).Select
Selection.Value = CDbl(Wert3)
Range("I65536").End(xlUp).Offset(1, 0).Select
Selection.Value = Wert4

Den kannst Du so abkürzen:

Code:

Sheets("Diverse").Select
Range("A65536").End(xlUp).Offset(1, 0).Value = Wert9
Range("B65536").End(xlUp).Offset(1, 0).Value = Wert8
Range("C65536").End(xlUp).Offset(1, 0).Value = Wert5
Range("D65536").End(xlUp).Offset(1, 0).Value = Wert6
Range("E65536").End(xlUp).Offset(1, 0).Value = Wert7
Range("F65536").End(xlUp).Offset(1, 0).Value = CDbl(Wert3)
Range("G65536").End(xlUp).Offset(1, 0).Value = CDbl(Wert3)
Range("I65536").End(xlUp).Offset(1, 0).Value = Wert4

Nun weiß ich nicht, ob Du in jeder Spalte eine unterschiedliche Anzahl Einträge hast. Da Du in jeder Spalte ...xlUp... hast, wird es wohl so sein. Falls nicht. kann man die Werte in ein Array packen und auf einmal eintragen.