Makro Fehlersuche bzw. Optimierung

Hallo,
da mir jetzt hier schon einmal sehr schnell und kompetent weiter geholfen wurde, hier ein weiteres Problem:
Ich habe zwei Datenreihen. In der ersten ganzzahlige x-Werte von 10 bis 5000 aufsteigend wobei jeder einzelne Wert öfters vorkommt und jeweils ein dazugehöriger y-Wert.
Kann man sich so vorstellen:
10 0,0001
10 0,0002
10 0,1234
10 0,4574
11 0,4344
11 0,9843
usw. (y-Werte hier rein zufällig)
Es soll folgendes gemacht werden: Es soll für jeden x-Wert der größte y-Wert erhalten bleiben. Die anderen Zeilen sollen gelöscht werden. Aus dem oberen soll also folgendes werden:
10 0,4574
11 0,9843
Mein Code sieht folgendermaßen aus:


Sub Reduktion2()
Dim j As Double
For j = 2 To 5000
If Cells(j, 1).Value = Cells(j + 1, 1).Value And Cells(j, 2).Value > Cells(j + 1, 2).Value Then
Cells(j + 1, 1).Delete Shift:=xlUp
Cells(j + 1, 2).Delete Shift:=xlUp
j = j - 1
ElseIf Cells(j, 1).Value = Cells(j + 1, 1).Value And Cells(j, 2).Value  "" Then
Cells(j, 1).Delete Shift:=xlUp
Cells(j, 2).Delete Shift:=xlUp
j = j - 1
End If
Next j
End Sub

Das Excel File hat ca. 65k Zeilen. Es gibt aber nur 4990 versch. x-Werte, deswegen läuft j nur bis 5000.
Beim ausführen bin ich noch nie zum Ende gekommen (nach 30min hab ich abgebrochen).
Braucht dieser Code für so viele Zeilen einfach solange? Falls ja, wie kann ich es optimieren?
Oder hab ich irgendwo eine Endlosschleife gebaut bzw. einen Fall nicht mitbedacht?
Hoffe irgendjemand sieht das Problem und kann mir helfen.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Reduktion2() Dim j As Long For j = 67679 To 2 Step -1 If Cells(j, 1).Value = Cells(j - 1, 1).Value And Cells(j, 2).Value > Cells(j - 1, 2).Value Then Cells(j - 1, 1).Delete Shift:=xlUp Cells(j - 1, 2).Delete Shift:=xlUp ElseIf Cells(j, 1).Value = Cells(j - 1, 1).Value And Cells(j, 2).Value "" Then Cells(j, 1).Delete Shift:=xlUp Cells(j, 2).Delete Shift:=xlUp End If Next j End Sub

Sub Reduktion3() Dim j As Long Dim arrData As Variant Dim dicResult As Object Set dicResult = CreateObject("Scripting.Dictionary") arrData = ActiveSheet.Cells(2, 1).Resize(4998, 2).Value 'hier ggf. die Range-Größe anahnd des letzten Eintrags ermitteln For j = 1 To UBound(arrData) If dicResult.exists(arrData(j, 1)) Then If dicResult(arrData(j, 1))

Sub Reduktion4() Dim j As Long Dim arrData As Variant Dim dicResult As Object Set dicResult = CreateObject("Scripting.Dictionary") arrData = ActiveSheet.Cells(2, 1).Resize(4998, 2).Value 'hier ggf. die Range-Größe anahnd des letzten Eintrags ermitteln For j = 1 To UBound(arrData) If dicResult.exists(arrData(j, 1)) Then If dicResult(arrData(j, 1))

Sub Reduktion() Dim j As Long Dim vntIN, vntOUT(), objOUT As Object, oObj Set objOUT = CreateObject("scripting.dictionary") vntIN = Cells(1, 1).CurrentRegion For j = 2 To UBound(vntIN) objOUT(vntIN(j, 1)) = Application.Max(objOUT(vntIN(j, 1)), vntIN(j, 2)) Next j ReDim vntOUT(1 To objOUT.Count + 1, 1 To 2) j = 1 vntOUT(j, 1) = "X" vntOUT(j, 2) = "Y" For Each oObj In objOUT j = j + 1 vntOUT(j, 1) = oObj vntOUT(j, 2) = objOUT(oObj) Next Worksheets.Add.Cells(1, 1).Resize(UBound(vntOUT), 2) = vntOUT End Sub

Beliebteste Forumthreads (12 Monate)

Makro Fehlersuche bzw. Optimierung

28 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

28
Beiträge zum Forumthread

Beiträge zu diesem Forumthread