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
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.
24.03.2017, 15:03 (Dieser Beitrag wurde zuletzt bearbeitet: 24.03.2017, 15:03 von 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.
Gruß Atilla
Folgende(r) 1 Nutzer sagt Danke an atilla für diesen Beitrag:1 Nutzer sagt Danke an atilla für diesen Beitrag 28 • 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:
27.03.2017, 10:20 (Dieser Beitrag wurde zuletzt bearbeitet: 27.03.2017, 10:20 von 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"
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".
![[-]](https://www.clever-excel-forum.de/images/collapse.png)