Kombinationen in einer Matrix auflisten

[joshua]

Hallo Leute!

Ich stehe momentan vor einer etwas komplexeren Aufgabe (für mich jedenfalls) und brauche mal wieder eure Hilfe (:

Ziel ist es, mögliche Kombinationen aus zwei Zahlen in einer Matrix aufsummiert zu bekommen.

Zahl A: 1-5
Zahl B: 1-5
Mögliche Kombinationen: 25

Entsprechend der Matrix kommen die Kombinationen in folgende Zellen:

1 x 1 > C8 
1 x 2 > C7
1 x 3 > C6
1 x 4 > C5
1 x 5 > C4


2 x 1 > D8
2 x 2 > D7
2 x 3 > D6
2 x 4 > D5
2 x 5 > D4

3 x 1 > E8
3 x 2 > E7
3 x 3 > E6
3 x 4 > E5
3 x 5 > E4

4 x 1 > F8
4 x 2 > F7
4 x 3 > F6
4 x 4 > F5
4 x 5 > F4

5 x 1 > G8
5 x 2 > G7
5 x 3 > G6
5 x 4 > G5
5 x 5 > G4

In Tabelle1 sind die Zahlen in Spalte D und E aufgelistet.
[url=
Dateiupload bitte im Forum! So geht es: Klick mich!
]


Da ich die Datensätze vorher durch diverse Prozeduren strukturiere und ordne, würde ich dieses Problem gerne wieder mit VBA lösen.
Hat hierzu jemand eine Idee oder Ansätze?

[Gast 123]

Hallo

anbei die Beispieldatei mit Makro zurück. Ich hoffe ich habe die Aufgabe richtig verstanden.

mfg Gast 123

[joshua]

Hallo Gast 123

Vielen Dank für Deine Lösung!

Sie ist nahezu perfekt (:

Da Kombinationen nicht nur einmal auftreten, soll in dem jeweiligen Feld in der Matrix die Summe aller Kombinationen gelistet werden. 
Wie ist dies nun zu integrieren?

[Gast 123]

Hallo

freut mich das ich die richtige Nase hatte, einfach nur den Code auswechseln    mfg Gast 123

Code:

Sub Matrix_auflisten()
Dim AC As Range, AJ As Range
Dim k As Integer, sp As Integer
Dim TB2 As Worksheet, Zahl As Integer
Set TB2 = Worksheets("Tabelle2")

With Worksheets("Tabelle1")
   TB2.Range("C4:G8") = Empty
   For k = 1 To 5
      For Each AC In .Range("D2:D14")
      If AC.Value = k Then
         sp = AC.Cells(1, 2)
         Zahl = TB2.Range("B9").Offset(-k, sp)
         TB2.Range("B9").Offset(-k, sp) = Zahl + 1
      End If
      Next AC
   Next k
End With
TB2.Select
End Sub

[Gast 123]

Nachtrag

sollte der Range Bereich einmal laenger sein einfach diesen Teil von Hand aendern:   es spielt keine Rolle wieviele Zeilen es sind.
For Each AC In .Range("D2:D14")

[atilla]

Hallo,

man kann die Angaben auch als Adressen verwenden, dann geht es sehr einfach so:

Code:

Sub test()
Dim i As Long

With Sheets("Tabelle2").Range("C4:G8")
.ClearContents
  For i = 2 To 14
    .Cells(6 - Sheets("Tabelle1").Cells(i, 4), Sheets("Tabelle1").Cells(i, 5)) = .Cells(6 - Sheets("Tabelle1").Cells(i, 4), Sheets("Tabelle1").Cells(i, 5)) + 1
  Next i
End With

End Sub

[snb]

Oder ?

Code:

Sub M_snb()
    sp = Sheets("Tabelle1").Range("D2:E14")
    With Sheets("Tabelle2").Range("C4:G8")
      .ClearContents
       sn = .Value
       
      For j = 1 To UBound(sp)
         sn(sp(j, 1), sp(j, 2)) = "x"
      Next
      
      .Value = sn
    End With
End Sub

[atilla]

Hallo,

und hier  snb' s Code angepasst auf die tatsächlichen Bedingungen und die zuletzt geäußerten Wünsche:

Code:

Sub M_snb()
  Dim j As Long
  Dim sp, sn
    sp = Sheets("Tabelle1").Range("D2:E14")
    With Sheets("Tabelle2").Range("C4:G8")
      .ClearContents
       sn = .Value
       
      For j = 1 To UBound(sp)
         sn(UBound(sn) + 1 - sp(j, 1), sp(j, 2)) = sn(UBound(sn) + 1 - sp(j, 1), sp(j, 2)) + 1
      Next
      
      .Value = sn
    End With
End Sub

[joshua]

Hallo atilla, snb und gast123!
Ich bedanke mich herzlichst bei euch (:

Der Eingangspost beinhaltet nicht die komplette Aufgabe. Ich dachte, wenn ich eine Lösung für die Matrix besitze, würde ich den Rest hinbekommen.
Leider ist dem nicht so :/
Ich hoffe ihr könnt euren Ansatz noch ein wenig ausweiten.

Ziel ist es nun, dass pro Gruppe/ Klasse (Spalte B) jeweils nur einmal einmal die höchste Kombination aus Spalte D&E in die Matrix B1 gesammelt wird und einmal die höchste Kombination pro Gruppe aus der Spalte D&J in die Matrix B2 eingetragen wird.

[url=
Dateiupload bitte im Forum! So geht es: Klick mich!
]
Meine Schwierigkeit ist nun, die For-Next-Schleife zu bilden.

[joshua]

Tabelle1
Ich habe nun den Code for atilla ein wenig adaptiert. Dabei ist mir nun ein potentieller Fehler aufgefallen.
Wenn eine der Zellen leer ist, so werden außerhalb der Range in Tabelle 2 Zahlen summiert pro Durchgang.

Wie kriege ich es nun sauber hin, dass Zellen, in denen 1 Zelle leer ist, nicht beachtet werden.

Code:

Sub CountTwo()

Dim i As Long
Dim ZeileMax As Long

   ZeileMax = Tabelle1.Cells(Rows.Count, "B").End(xlUp).Row
   
       With Sheets("Tabelle2").Range("L15:P19")
           .ClearContents
         For i = 2 To ZeileMax
           .Cells(6 - Sheets("Tabelle1").Cells(i, 17), Sheets("Tabelle1").Cells(i, 7)) = .Cells(6 - Sheets("Tabelle1").Cells(i, 17), Sheets("Tabelle1").Cells(i, 7)) + 1
         Next i
       End With
End Sub

Edit:
Habe es nun folgendermaßen hinbekommen:

Code:

If Tabelle1.Range("Q" & i).Value = "" Then _
              Else: .Cells(6 - Sheets("Tabelle1").Cells(i, 17), Sheets("Tabelle1").Cells(i, 7)) = .Cells(6 - Sheets("Tabelle1").Cells(i, 17), Sheets("Tabelle1").Cells(i, 7)) + 1

Vielleicht hat jemand eine elegantere Lösung (: