Übertragen von Daten und beschleunigen

Guten Abend,
ich brauche mal Profi Unterstützung.......
Ich versuche Daten von einer zur anderen Tabelle zu übertragen mit voriger Prüfung in Zeilen und Spalten.
Set wksQ = ThisWorkbook.Worksheets("Data")
Set wksZ = ThisWorkbook.Worksheets("Zeiten ")
Letzte1 = ThisWorkbook.Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
Letzte2 = ThisWorkbook.Worksheets("Zeiten").Cells(Rows.Count, "A").End(xlUp).Offset(5, 0).Row
For Q_x = 2 To Letzte1
If wksQ.Cells(Q_x, 7) = "x" Then
Artikel = wksQ.Cells(Q_x, 3)
Menge = wksQ.Cells(Q_x, 13)
Woche = wksQ.Cells(Q_x, 11)
For Z_X = 3 To Letzte2
If wksZ.Cells(Z_X, 3) = Artikel Then
MyRow = Z_X
For x = 9 To 248
If wksZ.Cells(6, x) = Woche Then
MyCol = x
wksZ.Cells(MyRow, MyCol) = Menge
End If
Next
End If
Next
End If
Next
Set wksQ = ThisWorkbook.Worksheets("Data")
Set wksZ = ThisWorkbook.Worksheets("Zeiten")
Letzte1 = ThisWorkbook.Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
Letzte2 = ThisWorkbook.Worksheets("Zeiten ").Cells(Rows.Count, "A").End(xlUp).Offset(5, 0).Row
For Q_x = 2 To Letzte1
If wksQ.Cells(Q_x, 7) = "y" Then
Artikel = wksQ.Cells(Q_x, 3)
Menge = wksQ.Cells(Q_x, 9)
Woche = wksQ.Cells(Q_x, 6)
For Z_X = 3 To Letzte2
If wksZ.Cells(Z_X, 3) = Artikel Then
MyRow = Z_X
For x = 9 To 248
If wksZ.Cells(6, x) = Woche Then
MyCol = x
wksZ.Cells(MyRow, MyCol) = Menge
End If
Next
End If
Next
End If
Das ganze funktioniert auch soweit allerdings versuche ich das ganze (x und y) zusammenzufassen.
Desweitern dauert der Code bei der Anzahl von Zeilen und Spalten über 8 Minuten.
Gibt es andere Möglichkeiten sowas umzusetzen bzw das ganze zu beschleunigen ?
Ich bin gerade froh das ich es so zusammengebaut habe das es überhaupt funktioniert.
Alles andere liegt weit über meinen können...
Würde mich wirklich sehr freuen wenn ihr mir helfen könntet.
Viele Grüße
Besten Dank
der Mani

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Moin,
ungetestet im Prinzip so:

Dim Q_x&, Z_X&, wksQ As Worksheet, wksZ As Worksheet
Dim MyRow&, MyCol&, x&
Dim Artikel$, Menge&, Woche$
Dim Letzte1 As Long
Dim Letzte2 As Long
Dim vntQ As Variant, vntZ As Variant
Sub Test()
Dim ldtStart As Date, ldtEnd As Date, ldtZeitunterschied As Date
ldtStart = Time
Set wksQ = ThisWorkbook.Worksheets("Data")
Set wksZ = ThisWorkbook.Worksheets("Zeiten")
Letzte1 = ThisWorkbook.Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
Letzte2 = ThisWorkbook.Worksheets("Zeiten").Cells(Rows.Count, "A").End(xlUp).Offset(5, 0). _
Row
vntQ = wksQ.Range(wksQ.Cells(1, 1), wksQ.Cells(Letzte1, 13)).Value
vntZ = wksZ.Range(wksZ.Cells(1, 1), wksZ.Cells(Letzte2, 29)).Value
For Q_x = 2 To Letzte1
If LCase(vntQ(Q_x, 7)) = "x" Then
Artikel = vntQ(Q_x, 3)
Menge = vntQ(Q_x, 13)
Woche = vntQ(Q_x, 11)
For Z_X = 3 To Letzte2
If vntZ(Z_X, 3) = Artikel Then
MyRow = Z_X
For x = 9 To 29
If vntZ(6, x) = Woche Then
MyCol = x
vntZ(MyRow, MyCol) = Menge
End If
Next
End If
Next
End If
Next
Set wksQ = ThisWorkbook.Worksheets("Data")
Set wksZ = ThisWorkbook.Worksheets("Zeiten")
Letzte1 = ThisWorkbook.Worksheets("Data").Cells(Rows.Count, "A").End(xlUp).Row
Letzte2 = ThisWorkbook.Worksheets("Zeiten").Cells(Rows.Count, "A").End(xlUp).Offset(5, 0). _
Row
For Q_x = 2 To Letzte1
If LCase(vntQ(Q_x, 7)) = "y" Then
Artikel = vntQ(Q_x, 3)
Menge = vntQ(Q_x, 9)
Woche = vntQ(Q_x, 6)
For Z_X = 3 To Letzte2
If vntZ(Z_X, 3) = Artikel Then
MyRow = Z_X
For x = 9 To 29
If vntZ(6, x) = Woche Then
MyCol = x
vntZ(MyRow, MyCol) = Menge
End If
Next
End If
Next
End If
Next
wksZ.Range(wksZ.Cells(1, 1), wksZ.Cells(Letzte2, 29)) = vntZ
ldtEnd = Time
ldtZeitunterschied = ldtEnd - ldtStart
MsgBox "fertig nach " & ldtZeitunterschied
End Sub

Gruß Gerd

Beliebteste Forumthreads (12 Monate)

Übertragen von Daten und beschleunigen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread