1,2,3 sayılarından Kombinasyon oluşturmak

[tamer42]

Merhaba,
Ekli dosyada Sayfa1' de belirtildiği üzere,
12 konuda 1, 2,3 rakamlarından oluşan en az 1 en çok 3 elaman bulunmaktadır.
buradaki sayıları kullanarak;
Sayfa2' de manuel oluşturduğum üzere, her biri bu şekilde 12 şer basamaklı sayıdan oluşan kombinasyonları nasıl bulabilirim?

Aşağıdaki döngüyü oluşturmaya çalıştım fakat devamını getiremedim,
desteğiniz için şimdiden teşekkürler,
iyi haftasonları...

Dim arr2() As Variant
Dim arr3() As Variant

Sub test()
Dim SH1 As Worksheet
Dim SH2 As Worksheet
Dim i As Byte, s As Long
Dim j As Byte

ReDim arr2(1 To 12, 1 To 2)
ReDim arr3(1 To 12, 1 To 2)

Set SH1 = Sayfa1
Set SH2 = Sayfa2

arr2 = SH1.Range("A2:B13").Value
arr3 = SH1.Range("C2:E13").Value

 SH1.Range("G1") = ""

s = 1

For i = 1 To 12

       s = s * SH1.Cells(i + 1, 2)
        
Next i

 SH1.Range("G1") = s

For i = 1 To 12
       SH2.Cells(2, i) = SH1.Cells(i + 1, 3)
Next i

For i = 1 To 12

s = SH1.Cells(i + 1, 2)

    If s > 1 Then
    
    For j = 2 To s
    
    Next j
    
    End If

Next i

End Sub

 

[veyselemre]

Sub test()
    Dim i, ii, iii, iv, v, vi, vii, viii, ix, x, xi, xii
    Dim s1, s2, veri, say, sat
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    ReDim sayi(1 To 12)
    For i = 1 To 12
        say = s1.Cells(i + 1, 2).Value
        ReDim veri(1 To say)
        For ii = 1 To say
            veri(ii) = s1.Cells(i + 1, ii + 2).Value
        Next ii
        sayi(i) = veri
    Next i
    sat = 2
    s2.Range("A2:L100").ClearContents
    For i = 1 To UBound(sayi(1))
        For ii = 1 To UBound(sayi(2))
            For iii = 1 To UBound(sayi(3))
                For iv = 1 To UBound(sayi(4))
                    For v = 1 To UBound(sayi(5))
                        For vi = 1 To UBound(sayi(6))
                            For vii = 1 To UBound(sayi(7))
                                For viii = 1 To UBound(sayi(8))
                                    For ix = 1 To UBound(sayi(9))
                                        For x = 1 To UBound(sayi(10))
                                            For xi = 1 To UBound(sayi(11))
                                                For xii = 1 To UBound(sayi(12))
                                                    s2.Cells(sat, 1).Resize(, 12).Value = _
                                                          Array(sayi(1)(i), sayi(2)(ii), sayi(3)(iii), sayi(4)(iv), sayi(5)(v), sayi(6)(vi), _
                                                                sayi(7)(vii), sayi(8)(viii), sayi(9)(ix), sayi(10)(x), sayi(11)(xi), sayi(12)(xii))
                                                    sat = sat + 1
    Next xii, xi, x, ix, viii, vii, vi, v, iv, iii, ii, i
End Sub

 

[tamer42]

Sub test()
    Dim i, ii, iii, iv, v, vi, vii, viii, ix, x, xi, xii
    Dim s1, s2, veri, say, sat
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    ReDim sayi(1 To 12)
    For i = 1 To 12
        say = s1.Cells(i + 1, 2).Value
        ReDim veri(1 To say)
        For ii = 1 To say
            veri(ii) = s1.Cells(i + 1, ii + 2).Value
        Next ii
        sayi(i) = veri
    Next i
    sat = 2
    s2.Range("A2:L100").ClearContents
    For i = 1 To UBound(sayi(1))
        For ii = 1 To UBound(sayi(2))
            For iii = 1 To UBound(sayi(3))
                For iv = 1 To UBound(sayi(4))
                    For v = 1 To UBound(sayi(5))
                        For vi = 1 To UBound(sayi(6))
                            For vii = 1 To UBound(sayi(7))
                                For viii = 1 To UBound(sayi(8))
                                    For ix = 1 To UBound(sayi(9))
                                        For x = 1 To UBound(sayi(10))
                                            For xi = 1 To UBound(sayi(11))
                                                For xii = 1 To UBound(sayi(12))
                                                    s2.Cells(sat, 1).Resize(, 12).Value = _
                                                          Array(sayi(1)(i), sayi(2)(ii), sayi(3)(iii), sayi(4)(iv), sayi(5)(v), sayi(6)(vi), _
                                                                sayi(7)(vii), sayi(8)(viii), sayi(9)(ix), sayi(10)(x), sayi(11)(xi), sayi(12)(xii))
                                                    sat = sat + 1
    Next xii, xi, x, ix, viii, vii, vi, v, iv, iii, ii, i
End Sub

Teşekkürler Veysel Hocam,
Sağolun, varolun...

 

[tamer42]

Veysel Hocam kombinasyon konusnda müsadelerinizle; kombinasyon konusunda bir soru daha sormak istiyorum;
ekli dosyada "b2:16" aralığında bulunan 15 adet rakamı, olabilecek tüm ihtimaller kapsamında;
2' şerli, 3' şerli 4' lerli gruplar halinde toplamak istiyordum
2' şerli gruplar halinde yapabildim, yalnız 2' den sonraki gruplamada takıldım,
bu konuda destek olursanız sevinirim.
iyi çalışmalar.

Sub test()
Dim SH1 As Worksheet
Dim SH2 As Worksheet
Dim i As Byte, j As Byte
Dim ss As Long


ReDim arr2(1 To 15, 1 To 1)


Set SH1 = Sayfa1
Set SH2 = Sayfa2

arr2 = SH1.Range("B2:B16").Value


ss = 0
' 2' serli gruplar halinde toplam

For i = LBound(arr2, 1) To UBound(arr2, 1) - 1

    For j = i To UBound(arr2, 1)
    
        ss = ss + arr2(j, 1)
    Next j
        
Next i

MsgBox ss

End Sub

 

[veyselemre]

Yanlış anlamadıysam 2,3,4 lü toplamları yazdım, diğerlerini siz ekleyin.

Sub test()
    Dim i, ii, iii, iv, v, vi

    ReDim sayi(1 To 15)
    For i = 1 To 15
        sayi(i) = Cells(i + 1, 2).Value
    Next i
    Range("C2:G10000").ClearContents
    sat = 2
    For i = 1 To 15
        For ii = 1 To 15
            If i <> ii Then
                Cells(sat, 3).Value = sayi(i) + sayi(ii)
                sat = sat + 1
            End If
        Next ii
    Next i
    sat = 2
    For i = 1 To 15
        For ii = 1 To 15
            For iii = 1 To 15
                If i <> ii And i <> iii And ii <> iii Then
                    Cells(sat, 4).Value = sayi(i) + sayi(ii) + sayi(iii)
                    sat = sat + 1
                End If
            Next iii
        Next ii
    Next i
    sat = 2
    For i = 1 To 15
        For ii = 1 To 15
            For iii = 1 To 15
                For iv = 1 To 15
                    If i <> ii And i <> iii And i <> iv And ii <> iii And ii <> iv And iii <> iv Then
                        Cells(sat, 5).Value = sayi(i) + sayi(ii) + sayi(iii) + sayi(iv)
                        sat = sat + 1
                    End If
                Next iv
            Next iii
        Next ii
    Next i

End Sub

 

[tamer42]

Yanlış anlamadıysam 2,3,4 lü toplamları yazdım, diğerlerini siz ekleyin.

Sub test()
  
  Dim i, ii, iii, iv, v, vi
    Dim sat As Long
    Dim sut As Byte
    Dim ub As Byte
  
  
    Application.Calculation = xlCalculationManual
  
    ub = 15
  
    ReDim sayi(1 To ub)
    For i = 1 To ub
        sayi(i) = Cells(i + 1, 2).Value
    Next i
  
    Range("G2:M100000").ClearContents
  
    sat = 2
    sut = 7
    For i = 1 To ub - 1
        For ii = i + 1 To ub
          
                Cells(sat, sut).Value = sayi(i) + sayi(ii)
                sat = sat + 1

        Next ii
    Next i
  
  
    sat = 2
    sut = 8
    For i = 1 To ub - 2
        For ii = i + 1 To ub - 1
            For iii = ii + 1 To ub
               
                    Cells(sat, sut).Value = sayi(i) + sayi(ii) + sayi(iii)
                    sat = sat + 1

            Next iii
        Next ii
    Next i
  
  
    sat = 2
    sut = 9
    For i = 1 To ub - 3
        For ii = i + 1 To ub - 2
            For iii = ii + 1 To ub - 1
                For iv = iii + 1 To ub

                        Cells(sat, sut).Value = sayi(i) + sayi(ii) + sayi(iii) + sayi(iv)
                        sat = sat + 1

                Next iv
            Next iii
        Next ii
    Next i
  
Application.Calculation = xlCalculationAutomatic

teşekkürler Veysel Hocam
burada topladığımız bir grup değişkenleri (toplamada değişim özelliği) bir defa daha toplamamak için kodu aşağıdaki şekle getirdim ama;
burada bir eksiklik olabilir mi?

Not: bunu dinamik hale getiremiyoruz sanırsam, kaçlı grup olacağını belirtip ona göre işlem yapması...