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

Tabelle nach Maximalwerten konsolidieren

Tabelle nach Maximalwerten konsolidieren
20.11.2015 17:02:21
Andreas
Hallo Forum,
habe wirklich schon sehr viel profitiert von diesem Forum. Jetzt habe ich eine Problemstellung, zu der ich noch nichts wirklich schönes gefunden habe (und mein Hirn gerade auch nicht so will ...)
Also: Denksport für's erste Winterwochenende ...
Ich habe eine Tabelle: Spalte A hat "Startnummern", Spalte B hat jeweils "Uhrzeiten" (Einlaufzeit).
Pro Runde gibt es pro Starter eine Zeile. Ein Starter hat (normalerweise) mehrere Runden (=Zeilen)
Sieht also in etwa so aus:
A - B
===========
3 - 1:20:10
2 - 1:20:20
4 - 1:20:21
1 - 1:20:23
2 - 1:30:15
1 - 1:30:20
3 - 1:30:30
Ich möchte diese Tabelle jetzt konsolidieren und zwar in der Form, dass pro Starter nur eine Zeile vorhanden ist und die jeweils grösste Zeit in Spalte B steht.
Oder in anderen Worten: mich interessiert pro Starter nur die letzte Einlaufzeit (alle anderen Einlaufzeiten / -zeilen sollen gelöscht werden).
Ergebnis wäre also wie folgt:
A - B
===========
4 - 1:20:21
2 - 1:30:15
1 - 1:30:20
3 - 1:30:30
Und als Bonus: in Spalte C hätte ich dann gerne noch die Anzahl Runden, die ein Starter hat (basierend auf der Ausgangstabelle). Ergebnis wäre dann also:
A - B - C
===============
4 - 1:20:21 - 1
2 - 1:30:15 - 2
1 - 1:30:20 - 2
3 - 1:30:30 - 2
In VBA, versteht sich. Mit Formeln will ich hier gar nicht erst anfangen ;-)
Hat jemand eine gute Idee für einen Algorithums?
Vielen Dank & Gruss
Andreas

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
noch ein Vorschlag
20.11.2015 23:45:38
Michael
Hi zusammen,
Luschis Vorschlag geht bei mir nicht mangels Aggregat.
Der Effekt ist aber schon komisch: beim Anwerfen des Makros stoppt es in der entsprechenden Codezeile, ich gehe auf Debuggen, lande im VBE, aber ich kann das Makro nicht beenden, nur die Datei schließen.
Egal: ich hatte anscheinend gleichzeitig mit dem Ding angefangen und ähnliche Ideen ...
Option Explicit
Sub ZamZlln()
Dim c As Range, r As Range
Dim d As Object, d2 As Object
Set r = Range("A1", (Cells(Rows.Count, 1).End(xlUp)))
Set d = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
For Each c In r
If d.exists(c.Value) Then
If d(c.Value) > c.Offset(, 1).Value Then
d(c.Value) = c.Offset(, 1).Value
End If
Else
d(c.Value) = c.Offset(, 1).Value
End If
d2(c.Value) = d2(c.Value) + 1
Next
Range("H10").Resize(d.Count + 3, 4).ClearContents
Range("H10").Resize(d.Count) = Application.Transpose(d.keys)
Range("I10").Resize(d.Count) = Application.Transpose(d.items)
Range("J10").Resize(d2.Count) = Application.Transpose(d2.items)
Range("H10").Resize(d.Count, 3).Sort Range("I10")
Set d = Nothing: Set d2 = Nothing: Set r = Nothing
End Sub

... nämlich das gute Dictionary.
Beide sträuben wir uns, ein Array ins dictionary zu übernehmen, das sowohl die Anzahl zählt als auch die kleinste Zeit beinhaltet.
Ich hab jetzt aber auch keinen Bock mehr, FR abend muß es was anderes geben als Excel.
Schöne Grüße,
Michael
P.S.: Wenn einen das *** schon nicht losläßt, also hier mit "arrays" alias "record" im dictionary:
Sub ZamZlln2()
Dim a As Variant, b As Variant
Dim d As Object
Dim j As Long, k As Long
ReDim b(2)
a = Range("A1", (Cells(Rows.Count, 1).End(xlUp))).Resize(, 3)
Set d = CreateObject("scripting.dictionary")
For j = 1 To UBound(a)
If d.exists(a(j, 1)) Then
b = d(a(j, 1)): b(1) = b(1) + 1
'      For k = LBound(b) To UBound(b): Debug.Print b(k): Next
If b(0) > a(j, 2) Then b(0) = a(j, 2)
Else
b(0) = a(j, 2): b(1) = 1
End If
d.Item(a(j, 1)) = b
Next
Range("H10").Resize(d.Count + 3, 4).ClearContents
' bißchen Platz schaffen außenrum
Range("I10").Resize(d.Count, UBound(a, 2)) = Application.Index(d.items, 0, 0)
Range("H10").Resize(d.Count) = Application.Transpose(d.keys)
Range("H10").Resize(d.Count, 3).Sort Range("I10")
Set d = Nothing
End Sub

Die mittlere Spalte der Ausgabe muß ggf. als "Zeit" formatiert werden.
Die Feinheiten habe ich mir bei
http://www.snb-vba.eu/VBA_Dictionary_en.html#L_23
(Beispiel 23.1) abgeschaut.

Anzeige
AW: noch ein Vorschlag
21.11.2015 15:15:14
Andreas
Wow... das scheint mir die hohe Schule der Excel-Programmierung zu sein ... Ich versteh euren Code schon mal gar nicht. Muss ich mir mal in Ruhe anschauen, was man mit dem "Scripting.Dictionary" so alles anstellen kann.
Mich hat's gestern abend natürlich auch nicht mehr in Ruhe gelassen. Hier mein Code. Ist halt "old-school" und etwas länger als eurer. Dafür kann (zumindest ich) ihn halbwegs lesen ;-)
Sub justDoIt()
Dim myWorksheet As Worksheet
Dim myRange As Range
Dim nRow As Integer
Dim nLastRow As Integer
Set myWorksheet = ThisWorkbook.Sheets("Sheet1")
Dim nStartNummer As Integer
Dim nRunden As Integer
Dim i As Integer
For nRow = 1 To myWorksheet.Cells(Cells.Rows.Count, 1).End(xlUp).Row
If IsNumeric(myWorksheet.Cells(nRow, 1)) And Not IsEmpty(myWorksheet.Cells(nRow, 1)) And  _
IsEmpty(myWorksheet.Cells(nRow, "F")) Then
nStartNummer = myWorksheet.Cells(nRow, 1)
nRunden = WorksheetFunction.CountIf(Range("A:A"), "=" & nStartNummer)
Debug.Print nStartNummer
Dim nLastRecordTime As Date
Dim nLastRecordRow As Integer
nLastRecordRow = -1
For i = nRow To myWorksheet.Cells(Cells.Rows.Count, 1).End(xlUp).Row
If myWorksheet.Cells(i, 1) = nStartNummer Then
myWorksheet.Cells(i, "C") = nRunden
If nLastRecordRow  nLastRecordTime Then
myWorksheet.Cells(nLastRecordRow, "F") = "x"
myWorksheet.Cells(i, "F") = "max"
nLastRecordTime = myWorksheet.Cells(i, "B")
nLastRecordRow = i
Else
myWorksheet.Cells(i, "F") = "x"
End If
End If
End If
Next
End If
Next
For nRow = myWorksheet.Cells(Cells.Rows.Count, 1).End(xlUp).Row To 1 Step -1
If myWorksheet.Cells(nRow, "F") = "x" Then
myWorksheet.Rows(nRow).Delete
End If
Next
myWorksheet.Columns("F:F").Delete
End Sub
Ich danke euch auf jeden Fall!
LG
Andreas

Anzeige
Danke für die Rückmeldung
21.11.2015 16:07:50
Michael
Hi zusammen,
"VBA gut" ist halt relativ: vor einem Jahr hätte ich gesagt, ich kann's so weit, aber denkste!
Je mehr man weiß, desto mehr weiß man, daß man nix weiß.
Soll heißen, das ganze Ding ist derart umfangreich, daß es nicht irre viele Leute gibt, die es beherrschen - im Forum tummeln sich glücklicherweise einige Vollprofis, deren Lösungsansaätze mich immer wieder ein Stück weiterschubsen.
Ich taste mich halt stückweise voran. Arrays sind nix Neues, wenn man sich mit irgendeiner Programmiersprache befaßt hat (bei mir war es Pascal), aber sie sind echt leicht einzulesen (a=range...) und um einen Faktor 800 (oder so) schneller als Zugriffe aufs Tabellenblatt.
Ich habe mal ne Reihe Tests gemacht und einen Bereich von 1152 Zellen gefüllt, mit 8 verschiedenen Algorithmen. Die Array-Variante war die Schnellste, verrückterweise aber *ohne* das Abschalten von screenupdate, calculate usw. - solange alles im "Speicher" erledigt wird, passiert auf dem Bildschirm sowieso nix, ebensowenig Neuberechnungen in der Tabelle.
Der Test ist in einer größeren Tabelle verbaut, aber wenn es Euch interessiert, extrahiere ich ihn mal.
Das Dictionary ist auch eine irre schnelle Sache, insbesondere, wenn man mehrfach vorkommende Werte nur einmal haben will.
Der Link oben (snb-vba.eu) ist klasse und in ein paar Stunden durchgeackert.
Also gut, weiterhin happy exceling,
Michael

Anzeige
AW: @Luschi: Schau mal ...
22.11.2015 17:49:15
Luschi
Hallo Herbert,
danke für den Tipp, das muß ich mir mal in Ruhe anschauen.
Gruß von Luschi
aus klein-Paris

Gerne geschehen!
22.11.2015 17:51:40
Herbert
Und wir sehen uns in Bonn!
Servus

306 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige