Hallo Zusammen,

ich habe unten aufgeführten Code von Lutz erhalten, der für das ursprüngliche Problem auch super funktioniert.  Das war

Auszug aus früherem Thread:

"Für die Arbeit benötige ich einen Code, der die verschiedenen Ausprägungen einzelner Versuche in allen möglichen Kombinationen addiert.  Da ich hunderte von Experimenten habe, die wiederum in mehreren Versuchen unterteilt, die jedoch immer die Ergebnisse in gleicher Form präsentieren, würde mir ein Makro jede Menge Arbeit abnehmen.

Beispiel: Versuch A gibt als Ergebnis X eine 0,4 für Ergebnis Y eine 0,56 und für Ergebnis Z eine 0,2 aus. Zusammen macht das 1,16.  Nun gibt es jedoch eine unbestimmte Anzahl “ N“ an Versuchen, die immer 3 Ergebnisse liefern.  Der Code soll auch die Ergebnisse von B bis hin zu N für X, Y und Z addieren. Z.B: XA (0,4) + YB (0,3) + ZN (0,23) = 0,93

                 A             B             N

X             0,4          0,2          0,15

Y             0,56       0,3          0,54

Z             0,2          0,4          0,23

Diejenige Kombination, die eine Summe  <1 hat, soll in ein anderes Tabellenblatt kopiert werden, sodas jeder wert einer Zelle zugewiesen ist.  Für obiges Beispiel wäre das etwa so:

Tabellenblatt2:
A1 = “A“; B1 = “X“; C1 = “0,4“
A2 = “B“; B2 = “Y“; C2= “0,3“
A3 = “N“; B2 = “Z“; C3 = “0,23“
A4 = 0,93

Ende Auszug"

 Dauraufhin hat mir Lutz die tolle Lösung gezeigt.
Wie kann ich diesen code jedoch erweitern, damit er nicht nur diese einen Tabelle berechnet, sondern viele untereinander, die immer die Werte X,Y und Z haben, jedoch unterschiedlich viele Spalten haben können. Die "nächste" Tabelle kommt immer 3 leerreihen nach der vorherigen Tabelle.

Ich hoffe ich konnte mein Problem gut genug erläutern.

Viele Grüße,

Justus

Public Sub Summieren()
    Dim dest As Worksheet
    Dim cl1 As Range
    Dim cl2 As Range
    Dim cl3 As Range
    Dim x_Werte As Range
    Dim y_Werte As Range
    Dim z_Werte As Range
    Dim destrg As Range
    Dim Summe As Double
    Set dest = Worksheets("Tabelle3")
    dest.Cells.Clear
    Set destrg = dest.Cells(1, 1)

    Set x_Werte = Range(Cells(2, 2), Cells(2, Range("A2").End(xlToRight).Column))
    Set y_Werte = Range(Cells(3, 2), Cells(3, Range("A3").End(xlToRight).Column))
    Set z_Werte = Range(Cells(4, 2), Cells(4, Range("A4").End(xlToRight).Column))

    For Each cl1 In x_Werte
        For Each cl2 In y_Werte
            For Each cl3 In z_Werte
                Summe = cl1.Value + cl2.Value + cl3.Value
                If Summe < 1 Then
                    rgarr = Array(cl1, cl2, cl3)
                    For idx = LBound(rgarr) To UBound(rgarr)
                        destrg.Offset(idx, 0).Value = Cells(1, rgarr(idx).Column).Value
                        destrg.Offset(idx, 1).Value = Cells(rgarr(idx).Row, 1)
                        destrg.Offset(idx, 2).Value = rgarr(idx).Value
                    Next idx
                    destrg.Offset(3, 0).Value = Summe
                    Set destrg = destrg.Offset(5, 0)
                End If
            Next
        Next
    Next
End Sub