Kombinationen in einer Matrix auflisten

[atilla]

Hallo Joshua,

hier meine Fassung korrigiert und mit Abfrage auf Spalte J:

Code:

Sub ati_mach()
 Dim i As Long
 Dim gesBereich, b1Bereich, b2Bereich

 Dim b1vonD1, b2vonD2
 Dim varKA
 Dim D1 As Object, D1A As Object
 Dim D2 As Object, D2A As Object
 
 Set D1 = CreateObject("Scripting.Dictionary")
 Set D1A = CreateObject("Scripting.Dictionary")
 Set D2 = CreateObject("Scripting.Dictionary")
 Set D2A = CreateObject("Scripting.Dictionary")
 gesBereich = Sheets("Tabelle1").Range("B2:J30")

 For i = 1 To UBound(gesBereich)
   varKA = gesBereich(i, 1)
   If gesBereich(i, 1) = varKA Then
     If CDbl(gesBereich(i, 3) & gesBereich(i, 4)) > D1(varKA) Then
       D1(varKA) = CDbl(gesBereich(i, 3) & gesBereich(i, 4))
       D1A(varKA) = gesBereich(i, 3) & " " & gesBereich(i, 4)
     End If
   
     If CDbl(gesBereich(i, 3) & gesBereich(i, 9)) > D2(varKA) Then
       D2(varKA) = CDbl(gesBereich(i, 3) & gesBereich(i, 9))
       D2A(varKA) = gesBereich(i, 3) & " " & gesBereich(i, 9)
     End If
   End If
 Next i
   

 With Sheets("Tabelle2").Range("C4:G8")
   .ClearContents
    b1Bereich = .Value
   For Each varKA In D2A.keys
      b1Bereich(Split(D1A(varKA))(0), Split(D1A(varKA))(1)) = b1Bereich(Split(D1A(varKA))(0), Split(D1A(varKA))(1)) + 1
   Next
   .Value = b1Bereich
 End With
 
 If Application.Count(Application.Index(Application.Transpose(gesBereich), 9)) > 0 Then
   With Sheets("Tabelle2").Range("J4:N8")
     .ClearContents
      b2Bereich = .Value
     For Each varKA In D2A.keys
        b2Bereich(Split(D2A(varKA))(0), Split(D2A(varKA))(1)) = b2Bereich(Split(D2A(varKA))(0), Split(D2A(varKA))(1)) + 1
     Next
     .Value = b2Bereich
   End With
 End If
End Sub

Normalerweise müsste die Abfrage am Anfang sein. Aber dann müsste ich den Code insgesamt verändern.
Das würde bei großen Datenmengen auf jeden fall Sinn machen.

[joshua]

Hallo Atilla,
ich habe nun wieder versucht deinen Code zu adaptieren, auf folgende Tabelle:

[url=
Dateiupload bitte im Forum! So geht es: Klick mich!
]
Leider funktioniert er nicht, wenn in Spalte Q keine Zahl enthalten ist.


Ziel ist es, für jede Klasse in Spalte E, die höchste Kombination aus Spalte G & I in Matrix 1 einzutragen und die höchste Kombination aus Spalte G und Q in die Matrix 2 einzutragen.
Sollte eine Klasse nur aus einer Zeile mit keinem Eintrag in Spalte Q bestehen, so soll die Klasse nicht betrachtet werden.
Sollte eine Klasse, mehrere Zeilen enthalten, und eine oder mehr davon enthalten in Spalte Q keinen Eintrag, so sollen die Kombination aus den anderen Zeilen gebildet werden.
Die Code sieht nun folgendermaßen aus. Sitze nun seit 9 Uhr dadran und komme nicht mehr weiter.

Code:

Sub CountAll()
 Dim i As Long 'Zeile
 Dim gesBereich, b1Bereich, b2Bereich

 Dim b1vonD1, b2vonD2
 Dim varKA
 Dim D1 As Object, D1A As Object
 Dim D2 As Object, D2A As Object
 
 Set D1 = CreateObject("Scripting.Dictionary")
 Set D1A = CreateObject("Scripting.Dictionary")
 Set D2 = CreateObject("Scripting.Dictionary")
 Set D2A = CreateObject("Scripting.Dictionary")
 gesBereich = Sheets("tblSummary").Range("E2:Q56")                         'Ausgewählten Bereich als gesBereich definieren

 For i = 1 To UBound(gesBereich)                                           'Zeile 1(B2) bis Spaltenende(J56)
   varKA = gesBereich(i, 1)                                                'varZeile und Spalte 1
   If gesBereich(i, 1) = varKA Then                                        'Wenn Zelle gesBereich gleich varKA, dann >
     If CDbl(gesBereich(i, 3) & gesBereich(i, 5)) > D1(varKA) Then         'Wenn Zelle Spalte 3 (D) größer als Zelle Spalte 4 (E), dann >
       D1(varKA) = CDbl(gesBereich(i, 3) & gesBereich(i, 5))
       D1A(varKA) = gesBereich(i, 3) & " " & gesBereich(i, 5)
     End If
   
     If CDbl(gesBereich(i, 3) & gesBereich(i, 13)) > D2(varKA) Then
       D2(varKA) = CDbl(gesBereich(i, 3) & gesBereich(i, 13))
       D2A(varKA) = gesBereich(i, 3) & " " & gesBereich(i, 13)
     End If
   End If
 Next i
   

 With Sheets("tbl_matrix").Range("D5:H9")
   .ClearContents
    b1Bereich = .Value
   For Each varKA In D2A.keys
      b1Bereich(Split(D1A(varKA))(0), Split(D1A(varKA))(1)) = b1Bereich(Split(D1A(varKA))(0), Split(D1A(varKA))(1)) + 1
   Next
   .Value = b1Bereich
 End With
 
 If Application.Count(Application.Index(Application.Transpose(gesBereich), 13)) > 0 Then
   With Sheets("tbl_matrix").Range("L5:P9")
     .ClearContents
      b2Bereich = .Value
     For Each varKA In D2A.keys
        b2Bereich(Split(D2A(varKA))(0), Split(D2A(varKA))(1)) = b2Bereich(Split(D2A(varKA))(0), Split(D2A(varKA))(1)) + 1
     Next
     .Value = b2Bereich
   End With
 End If
End Sub

Tut mir leid, dass ich die erste Mustertabelle so "simple" gestaltet habe. Ich dachte ich könnte die Code einfach anpassen. In Zukunft werde ich mehr drauf achten.

Und nochmals vielen Dank für deine Hilfe und Untersützung.

[atilla]

Hallo Joshua,

das ist nicht mehr schön.
Du solltest aber Beispiele so einstellen, das man die von Dir erwähnten Besonderheiten sehen kann.
Am besten mit Ergebnissen.

Auf die Schnelle werde ich jetzt keine Lösung posten können.
Vielleicht schaue ich mir das am Wochenende mal genauer an.
Als Müßiggang quasi.

[joshua]

Hallo atilla,

ich bedanke mich für deine Lösungen, Hilfestellung und Lösungen.

Du hast vollkommen recht. Ich sollte mehr Zeit für die Beispieltabelle und die Lösungsskizze investieren.
Ich wollte nur versuchen, selbst anhand einer Basis, die Lösungen dann zu adaptieren.
Leider bin ich in dieser Hinsicht/ Kompetenzen noch sehr weit entfernt.


Beste Grüße