VBA-Code für Minimum anhand von Kriterium gesucht

Hallo zusammen!
Ich suche Hilfe beim Erstellen eines VBA- Codes.
Es soll nach Möglichkeit folgendes umgesetzt werden.
Anhand des Kriteriums Typ "T1" in Spalte B soll für jeden unterschiedlich hinterlegten Code in Spalte A entweder "GT" oder "VT" ausgeben werden ("VT" oder "GT" sollen in Spalte D eingetragen werden).
"GT" soll ausgegeben werden, wenn ein Code in Spalte A nur einmal vorkommt. "VT" soll hinterlegt werden, wenn ein Code mehrfach vorkommt. Dabei soll das "VT" genau in der Zeile hinterlegt werden, wo der Code in Spalte C einen minimalen Wert annimmt. Falls 2 oder mehr minimale Werte vorkommen, dann soll "VT" aber nur einmal hingeschrieben werden. Das ganze soll dann noch für das Kriterium "T2" gemacht werden... Aber das sollte dann ja kein Problem sein, wenn es für "T1" klappt.Die Zeilenanzahl varriert dabei ständig, bwz. kann nach der Aktualisierung der Daten variieren. Das klingt nun sehr kompliziert, zum besseren Verständnis habe ich eine Beispiel- Datei im Anhang hochgeladen. Wenn ihr noch Fragen habt, dann fragt einfach noch einmal nach, wenn ich mich undeutlich ausgedrückt habe. Ich würde mich freuen, wenn ihr mir helfen würdet. Ich hänge dabei, wenn geprüft werden soll wie oft ein Code in Spalte A vorkommt...Wie geht man da denn am besten vor?
https://www.herber.de/bbs/user/90814.xls
Viele Grüße, Vigo

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub TestIt() Dim lngLR As Long, i As Long Dim strKey As String Dim objMin As Object Dim objCnt As Object Set objMin = CreateObject("Scripting.Dictionary") Set objCnt = CreateObject("Scripting.Dictionary") With Sheets("Tabelle1") lngLR = .Cells(Rows.Count, 1).End(xlUp).Row .Cells(2, 4).Resize(lngLR - 1).ClearContents For i = 2 To lngLR strKey = .Cells(i, 2).Text & .Cells(i, 1).Text If objMin.Exists(strKey) Then If .Cells(i, 3).Value 1 Then .Cells(i, 4) = "VT" Else .Cells(i, 4) = "GT" End If objMin.Remove (strKey) End If Next End With Set objMin = Nothing Set objCnt = Nothing End Sub

Hallo Christian!
Danke für deine Antwort. Ich hab sie leider zu spät gesehen und bin eben auch auf eine andere Lösung mit einer Arrayformel gestoßen(dazu muss ich sagen, dass diese Formel jemand anderes geschrieben hat, so gut bin ich leider noch nicht :( )

Sub Test()
Dim i As Long, da1 As Boolean
With Worksheets("Tabelle1")
For i = 2 To 1000
If Cells(i, 2) = "T1" Then
da1 = True
Exit For
End If
Next i
For i = 2 To 1000
If Cells(i, 2) = "T1" Then
If da1 = True Then Cells(i, 5).FormulaArray = "=IF(SUM((R2C1:R1000C1=RC1)*(R2C2:R1000C2= _
""T1""))>1,IF(AND(MIN(IF((R2C1:R1000C1=RC1)*(R2C2:R1000C2=""T1""),(R2C3:R1000C3)+ROW(R2C3:R1000C3)/100000))=RC3+ROW()/100000,RC2=""T1""),""VT"",""""),IF(RC2=""T1"",""GT"",""""))"
End If
Next i
For i = 2 To 1000
If Cells(i, 2) = "T2" Then
da1 = True
Exit For
End If
Next i
For i = 2 To 1000
If Cells(i, 2) = "T2" Then
If da1 = True Then Cells(i, 5).FormulaArray = "=IF(SUM((R2C1:R1000C1=RC1)*(R2C2:R1000C2= _
""T2""))>1,IF(AND(MIN(IF((R2C1:R1000C1=RC1)*(R2C2:R1000C2=""T2""),(R2C3:R1000C3)+ROW(R2C3:R1000C3)/100000))=RC3+ROW()/100000,RC2=""T2""),""VT"",""""),IF(RC2=""T2"",""GT"",""""))"
End If
Next i
End With
End Sub

Ich werde deine Lösung aber auch mal ausprobieren, um zu sehen, ob das wirklich schneller abläuft. Danke, dass du dir das mal angeschaut hast! Einen schönen Samstag noch!
Viele Grüße, Vigo

Beliebteste Forumthreads (12 Monate)

VBA-Code für Minimum anhand von Kriterium gesucht

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA-Code für Minimum anhand von Kriterium gesucht

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread