Excel ile Olasılık Hesabı

[akayemrecan]

Arkadaşlar merhaba, elimde 10 haneli sayı ve harf içeren kodlar var. Kodların içerisindeki B harflerini 8 ile, S harflerini 5 ile, I harflerini 1 ile, O harflerini 0 ile, Z harflerini 2 ile değiştirip elimdeki kodun tüm kombinasyonlarını bulmam gerekiyor. Örnek kodu kombinasyonları ile dosyaya yazdım. A sütununa yapıştırdığım kodun kombinasyonlarını kodun yanındaki hücrelere yazan vba kodunu paylaşabilir misiniz?
Şimdiden teşekkür ederim

 

[akayemrecan]

Arkadaşlar yardımcı olabilecek var mı aranızda?

 

[akayemrecan]

@Korhan Ayhan hocam eğer müsaitsen bir göz atabilir misin rica etsem? Çok zor bir şey mi bilmiyorum ama zamanınızı alacaksa sorun değil.

 

[ÖmerFaruk]

Gönderdiğiniz dosyada yeteri kadar özenle hazırlanmış bir veri yok. Anlattığınızla uyuşmuyor. Ya anlatımınız ya da dosyanız hatalı.
Sorunuz 150 defa görüntülenmiş ama yardımcı olunamamış.

 

[ÖmerBey]

Merhaba,
Biraz karmaşık oldu gibi ama aşağıdaki kodları dener misiniz?

Sub kod()
bul = "BSIOZ"
deg = "85102"
Set d = CreateObject("Scripting.Dictionary")
For a = 1 To Cells(Rows.Count, "A").End(3).Row
    m = Cells(a, "A").Text
    ReDim dz(1 To Len(m), 1 To 2)
    For b = 1 To Len(m)
        dz(b, 1) = Mid(m, b, 1)
        If InStr(1, bul, Mid(m, b, 1)) = 0 Then dz(b, 2) = Mid(m, b, 1) Else dz(b, 2) = Mid(deg, InStr(1, bul, Mid(m, b, 1)), 1)
    Next
    ReDim dz2(1 To UBound(dz))
    ReDim s(1 To UBound(dz))
    For b = LBound(s) To UBound(s)
        s(b) = 1
    Next
    
    Do
        For b = LBound(s) To UBound(s)
            dz2(b) = dz(b, s(b))
        Next
        
        If Not d.exists(Join(dz2, "")) Then
            d.Add Join(dz2, ""), 1
        End If

        s(UBound(s)) = s(UBound(s)) + 1
        If s(UBound(s)) > 2 Then
        For b = UBound(s) To LBound(s) + 1 Step -1
            If s(b) > 2 Then
                s(b - 1) = s(b - 1) + 1
                s(b) = 1
            End If
        Next
        If s(LBound(s)) > 2 Then GoTo 1
    Else
      
    End If
    Loop
1
Cells(a, "B").Resize(1, d.Count).Value = d.Keys()
d.RemoveAll
Next
End Sub

 

[akayemrecan]

Merhaba,
Biraz karmaşık oldu gibi ama aşağıdaki kodları dener misiniz?

Sub kod()
bul = "BSIOZ"
deg = "85102"
Set d = CreateObject("Scripting.Dictionary")
For a = 1 To Cells(Rows.Count, "A").End(3).Row
    m = Cells(a, "A").Text
    ReDim dz(1 To Len(m), 1 To 2)
    For b = 1 To Len(m)
        dz(b, 1) = Mid(m, b, 1)
        If InStr(1, bul, Mid(m, b, 1)) = 0 Then dz(b, 2) = Mid(m, b, 1) Else dz(b, 2) = Mid(deg, InStr(1, bul, Mid(m, b, 1)), 1)
    Next
    ReDim dz2(1 To UBound(dz))
    ReDim s(1 To UBound(dz))
    For b = LBound(s) To UBound(s)
        s(b) = 1
    Next
   
    Do
        For b = LBound(s) To UBound(s)
            dz2(b) = dz(b, s(b))
        Next
       
        If Not d.exists(Join(dz2, "")) Then
            d.Add Join(dz2, ""), 1
        End If

        s(UBound(s)) = s(UBound(s)) + 1
        If s(UBound(s)) > 2 Then
        For b = UBound(s) To LBound(s) + 1 Step -1
            If s(b) > 2 Then
                s(b - 1) = s(b - 1) + 1
                s(b) = 1
            End If
        Next
        If s(LBound(s)) > 2 Then GoTo 1
    Else
     
    End If
    Loop
1
Cells(a, "B").Resize(1, d.Count).Value = d.Keys()
d.RemoveAll
Next
End Sub

Hocam çok teşekkür ederim çok işimi gördü sağolun. Emeğinize sağlık.

 

[ÖmerBey]

Rica ederim,
İyi çalışmalar...

 

[veyselemre]

Alternatif;

Sub test()
    Dim a, al, i, ii, iii, iv, v, vi, vii, viii, ix, x, sut, h(1 To 10)
    For a = 1 To Cells(Rows.Count, 1).End(3).Row
        al = Cells(a, 1).Value
        sut = 2
        For i = 1 To 10
            h(i) = Mid(al, i, 1)
            Select Case h(i)
                Case "B": h(i) = h(i) & "," & 8
                Case "S": h(i) = h(i) & "," & 5
                Case "I": h(i) = h(i) & "," & 1
                Case "O": h(i) = h(i) & "," & 0
                Case "Z": h(i) = h(i) & "," & 2
            End Select
        Next i
        For Each i In Split(h(1), ",")
            For Each ii In Split(h(2), ",")
                For Each iii In Split(h(3), ",")
                    For Each iv In Split(h(4), ",")
                        For Each v In Split(h(5), ",")
                            For Each vi In Split(h(6), ",")
                                For Each vii In Split(h(7), ",")
                                    For Each viii In Split(h(8), ",")
                                        For Each ix In Split(h(9), ",")
                                            For Each x In Split(h(10), ",")
                                                Cells(a, sut).Value = i & ii & iii & iv & v & vi & vii & viii & ix & x
                                                sut = sut + 1
        Next x, ix, viii, vii, vi, v, iv, iii, ii, i
    Next a
End Sub