Kombinationen in einer Matrix auflisten

[snb]

Code:

Sub M_snb()
    sn = Sheet1.Cells(1, 2).CurrentRegion.Resize(, 10)

    Sheet2.Range("C4:G8").ClearContents
    sp = Sheet2.Range("C4:G8")
    sq = sp
    
    For j = 2 To UBound(sn)
       If sn(j, 1) <> sn(1, 2) Then
          If sn(1, 5) <> "" Then
            sp(sn(1, 5), sn(1, 6)) = "x"
            sq(sn(1, 5), sn(1, 7)) = "x"
          End If
          sn(1, 2) = sn(j, 1)
          sn(1, 5) = sn(j, 3)
          sn(1, 6) = sn(j, 4)
          sn(1, 7) = sn(j, 9)
       Else
          If sn(j, 4) > sn(1, 6) Then sn(1, 6) = sn(j, 4)
          If sn(j, 9) > sn(1, 7) Then sn(1, 7) = sn(j, 9)
       End If
    Next
    sp(sn(1, 5), sn(1, 6)) = "x"
    sq(sn(1, 5), sn(1, 7)) = "x"
    
    Sheet2.Range("C4:G8") = sp
    Sheet2.Range("J4:N8") = sq
End Sub

[joshua]

Hallo snb,

vielen Dank für Deinen Ansatz/ Lösung.

Ich versuche momentan den Code mit F8 zu verstehen aber komme gerade nicht ganz so mit :/

Ich muss mich entschuldigen, dass ich die Beispieltabelle nicht ausreichen definiert habe. Diese Tabelle besitzt in den leeren Zellen eigentlich Text. Diesen habe ich nun gefüllt und im Anhang aufgeführt, da der Code nicht funktioniert, wenn Text in den leeren Zellen enthalten ist.

Zusätzlich würde ich gerne kein x in der matrix aufweisen, sondern jeweils die Summe aller, da manche KOmbination auch öfter auftreten können.
Habe versucht atillas Beitrag zu deinem Code zu adaptieren, aber bisher nicht hinbekommen.



Mit besten Grüßen

[atilla]

Hallo Joshua,

das wird etwas komplizierter:

Code:

Option Explicit

Sub ati_mach()
 Dim i As Long
 Dim gesBereich, b1Bereich, b2Bereich
 Dim b1vonD1, b2vonD2
 Dim varKA As String, varkB As String
 Dim D1 As Object, D2 As Object
 
 Set D1 = CreateObject("Scripting.Dictionary")
 Set D2 = 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))
     End If
   
     If CDbl(gesBereich(i, 3) & gesBereich(i, 9)) > D2(varKA) Then
       D2(varKA) = CDbl(gesBereich(i, 3) & gesBereich(i, 9))
     End If
   End If
 Next i
   
 b1vonD1 = D1.items
 b2vonD2 = D2.items

 With Sheets("Tabelle2").Range("C4:G8")
   .ClearContents
    b1Bereich = .Value
   For i = 0 To UBound(b1vonD1)
      b1Bereich(UBound(b1Bereich) + 1 - Left(b1vonD1(i), 1), Right(b1vonD1(i), 1)) = b1Bereich(UBound(b1Bereich) + 1 - Left(b1vonD1(i), 1), Right(b1vonD1(i), 1)) + 1
   Next
   .Value = b1Bereich
 End With
 
 With Sheets("Tabelle2").Range("J4:N8")
   .ClearContents
    b2Bereich = .Value
   For i = 0 To UBound(b2vonD2)
      b2Bereich(UBound(b2Bereich) + 1 - Left(b2vonD2(i), 1), Right(b2vonD2(i), 1)) = b2Bereich(UBound(b2Bereich) + 1 - Left(b2vonD2(i), 1), Right(b2vonD2(i), 1)) + 1
   Next
   .Value = b2Bereich
 End With
 
End Sub

Diese Variante funktioniert nur mit einstelligen Zahlen.
Falls Du größere Matrizen hast, muss der Code erneut erweitert werden.

Teste erst mal, ob dieser richtig funktioniert.

[joshua]

Hallo atilla,
vielen Dank für Deinen Vorschlag.

Ich überprüfe diesen am Montag. 

Das ist soweit richtig mit den einstelligen Zahlen. Diese liegen immer bei 1-5.

[atilla]

Hallo Joshua,

habe jetzt schon eine erweiterte Version, die auch mit größeren Zahlen arbeiten sollte:

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(UBound(b1Bereich) + 1 - Split(D1A(varKA))(0), Split(D1A(varKA))(1)) = b1Bereich(UBound(b1Bereich) + 1 - Split(D1A(varKA))(0), Split(D1A(varKA))(1)) + 1
   Next
   .Value = b1Bereich
 End With
 
 With Sheets("Tabelle2").Range("J4:N8")
   .ClearContents
    b2Bereich = .Value
   For Each varKA In D2A.keys
      b2Bereich(UBound(b2Bereich) + 1 - Split(D2A(varKA))(0), Split(D2A(varKA))(1)) = b2Bereich(UBound(b2Bereich) + 1 - Split(D2A(varKA))(0), Split(D2A(varKA))(1)) + 1
   Next
   .Value = b2Bereich
 End With

End Sub

Weitere Vereinfachung des Codes sind anderen überlassen. :19:

[snb]

Code:

Sub M_snb()
    sn = Sheet1.Cells(1, 2).CurrentRegion.Resize(, 10)

    Sheet2.Range("C4:G8").ClearContents
    sp = Sheet2.Range("C4:G8")
    sq = sp
    
    For j = 2 To UBound(sn)
       If sn(j, 1) <> sn(1, 2) Then
          If sn(1, 5) <> "" Then
            sp(sn(1, 5), sn(1, 6)) = sp(sn(1, 5), sn(1, 6))+1
            sq(sn(1, 5), sn(1, 7)) = sq(sn(1, 5), sn(1, 7))+1
          End If
          sn(1, 2) = sn(j, 1)
          sn(1, 5) = sn(j, 3)
          sn(1, 6) = sn(j, 4)
          sn(1, 7) = sn(j, 9)
       Else
          If sn(j, 4) > sn(1, 6) Then sn(1, 6) = sn(j, 4)
          If sn(j, 9) > sn(1, 7) Then sn(1, 7) = sn(j, 9)
       End If
    Next
    sp(sn(1, 5), sn(1, 6)) =  sp(sn(1, 5), sn(1, 6))+1
    sq(sn(1, 5), sn(1, 7)) = sq(sn(1, 5), sn(1, 7))+1
    
    Sheet2.Range("C4:G8") = sp
    Sheet2.Range("J4:N8") = sq
End Sub

[joshua]

Hallo atilla,

ich habe soweit deinen Code an meine Mappe angepasst.
Dieser funktioniert! Merci!

Ich würde gerne noch eine Bedingung in deinem letzten Part einfügen.

Und zwarkriege ich im folgenden Teil eine Fehlermeldung (Typen unverträglich)

Code:

For Each varKA In D2A.keys
      b2Bereich(UBound(b2Bereich) + 1 - Split(D2A(varKA))(0), Split(D2A(varKA))(1)) = b2Bereich(UBound(b2Bereich) + 1 - Split(D2A(varKA))(0), Split(D2A(varKA))(1)) + 1
   Next

 wenn in Spalte J nichts steht.
Ich würde gerne die komplette Zeile nicht in Betracht Ziehen, wenn in J keine Zahl ist.
Diese Zeilen zähle ich bereits im Vorfeld über die CountIf-Funktion.
Wie ist dies zu bewerkstelligen?
Ebenfalls werden A und B in der Matrix falsch eingesetzt bzw. vertauscht.
A kommt in die horizonalte und B in die vertikale.
Beste Grüße
Joshua


edit: @snb: bekomme mit deinem Code den Fehlercode "Außerhalb des Index"

[snb]

Verwende F8

[joshua]

Verwende F8

Das habe ich bereits.
Fehler tritt in folgender Zeile auf:

Code:

           sq(sn(1, 5), sn(1, 7)) = sq(sn(1, 5), sn(1, 7)) + 1

Warum arbeiten wir hier mit ""?

Code:

If sn(1, 5) <> "" Then
           sp(sn(1, 5), sn(1, 6)) = sp(sn(1, 5), sn(1, 6)) + 1
           sq(sn(1, 5), sn(1, 7)) = sq(sn(1, 5), sn(1, 7)) + 1
         End If

Die Spalten besitzen ja einen Eintrag.

[joshua]

Hallo snb,

ich bin gerade dabei nochmal deinen Code durchzugehen. Diesen verstehe ich leider nicht so ganz :/

Code:

         If sn(1, 5) <> "" Then
           sp(sn(1, 5), sn(1, 6)) = sp(sn(1, 5), sn(1, 6)) + 1
           sq(sn(1, 5), sn(1, 7)) = sq(sn(1, 5), sn(1, 7)) + 1
          End If

Ich verstehe zwar nun, dass wenn ich Spalte 5 ein Wert steht, er etwas machen soll, nur verstehe ich nicht, warum hierfür die Spalten 5&6 betrachtet werden. In diesen sind doch keine Werte bzw. nur Text enthalten. Die Zahlen sind doch erst in Spalte D&E bzw. 3&4.
Ebenfalls kriege ich bei "sq(sn(1, 5), sn(1, 7)) = sq(sn(1, 5), sn(1, 7)) + 1" immer noch den Fehler "Typen unversträglich".

Beste Grüße
Joshua