Sayı yerleştirerek sonuca ulaşma Makrosu

[akmlyx]

Değerli Arkadaşlar yazılacak makro ekteki sarı renk ile gösterilen A2 hücresinden D2 hücresine kadar olan her bir hücreye kendi hücrelerinin altında bulunan mavi sütundaki rakamlar(sıfırdan dokuza kadar) sırasıyla yerleştirilecek, yerleştirilen rakamların toplamasını yazdığım formül yaptıktan sonra sonucu doğru olarak tespit edince, G2 hücresinde bulunan rakamı kopyalayıp H2 hücresine değer olarak yapıştıracak, daha sonra sıradaki rakamdan(Örneğin ilk önce 1000 ardından 1001 ardından 1002 gibi) denemeye devam edecek bir makro acaba mümkün olabilir mi? İlgilenen arkadaşa şimdiden Teşekkür ederim.

 

[Muzaffer Ali]

Merhaba.

Doğru mu anladım bilemiyorum ama aşağıdaki kodu deneyin.

Kodu sayfanın kod sayfasına kopyalayın. E2 hücresinde bir değişiklik yaptığınızda kodlar otomatik çalışacaktır.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim A As Byte, B  As Byte, C  As Byte, D  As Byte
    If Not Intersect(Target, Range("E2")) Is Nothing Then
        For A = 0 To 9
            For B = 0 To 9
                For C = 0 To 9
                    For D = 0 To 9
                        If A + B + C + D = Range("E2").Value Then
                            Range("A2").Value = A
                            Range("B2").Value = B
                            Range("C2").Value = C
                            Range("D2").Value = D
                            Range("H2").Value = A & B & C & D
                        End If
                    Next
                Next
            Next
        Next
    End If
End Sub

 

[akmlyx]

Muzaffer Ali hocam sorum ile ilgilendiğiniz için çok teşekkür ederim. Hocam, sizin yazdığınız makroyu kod sayfasına yapıştırdım, Form Denetimlerinden butona makro atamak istedim fakat makro görünmedi neden olabilir acaba?

 

[akmlyx]

 

[Muzaffer Ali]

Makro listesinde görünmesi için aşağıdaki kodu bir modüle kopyalayın.

Sub Test
    Dim A As Byte, B  As Byte, C  As Byte, D  As Byte
    If Not Intersect(Target, Range("E2")) Is Nothing Then
        For A = 0 To 9
            For B = 0 To 9
                For C = 0 To 9
                    For D = 0 To 9
                        If A + B + C + D = Range("E2").Value Then
                            Range("A2").Value = A
                            Range("B2").Value = B
                            Range("C2").Value = C
                            Range("D2").Value = D
                            Range("H2").Value = A & B & C & D
                        End If
                    Next
                Next
            Next
        Next
    End If
End Sub

 

[ÖmerFaruk]

Ben farklı anladım ama benzer bir çalışma yaptım.
Kodlar ekte.
Bu kodları sayfanın kod sayfasına aynen yapıştırın.
E2 hücresine toplamı girince tüm sayıları listeliyor

Private Sub Worksheet_Change(ByVal Target As Range)
    If Intersect(Target, [E2]) Is Nothing Then Exit Sub
    If Not IsNumeric(Target) Then MsgBox ("istenen sonuç 1-36 arasında sayısal bir değer olmalıdır"): Exit Sub
    If Target < 1 Then MsgBox ("istenen sonuç en az 1 olmalıdır"): Exit Sub
    If Target > 36 Then MsgBox ("istenen sonuç en fazla 36 olmalıdır"): Exit Sub
    Range("A2:D2").ClearContents
    Range("H2:H" & Rows.Count).Clear
    Say = 1
    For a = 1 To 9
        For b = 0 To 9
            For c = 0 To 9
                For d = 0 To 9
                    Range("A2") = a
                    Range("B2") = b
                    Range("C2") = c
                    Range("D2") = d
                    If a + b + c + d = Range("E2") Then
                        Say = Say + 1
                        Range("F2") = "Doğru"
                        Range("H" & Say) = 1000 * a + 100 * b + 10 * c + d
                    ElseIf Range("F2") = "Doğru" Then
                        Range("F2") = "Yanlış"
                    End If
                Next d
            Next c
        Next b
    Next a
    With Range("H1").Resize(Say, 1)
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    End With
End Sub

 

[akmlyx]

Hocalarım maalesef her iki makro da çalışmadı yada ben çalıştıramadım.

 

[Muhammet Okumuş]

Dizi ile sonuca daha hızlı ulaşırsınız. 3 basamaklı sonuçları bulmaz.

Sub Bul()
Application.ScreenUpdating = False
Range("H2:H10000").ClearContents
hdf = Range("E2").Value
If hdf > 36 Or Not IsNumeric(hdf) Then Exit Sub
ReDim Tablo(1 To 1000, 1 To 1)

For a = 1 To 9
For b = 0 To 9
For c = 0 To 9
For d = 0 To 9
If a + b + c + d = hdf Then
n = n + 1
Tablo(n, 1) = a & b & c & d

End If



Next
Next
Next
Next
If n = 0 Then Exit Sub
Range("H2").Resize(n, 1) = Tablo
End Sub

Eğer a = 1 to 9 yerine 0 to 9 yaparsanız 3, 2, 1 basamaklı sonuçları da bulur.

 

[akmlyx]

Dizi ile sonuca daha hızlı ulaşırsınız. 3 basamaklı sonuçları bulmaz.



Eğer a = 1 to 9 yerine 0 to 9 yaparsanız 3, 2, 1 basamaklı sonuçları da bulur.

Muhammet Okumuş Hocam elinize sağlık güzel bir makro çalışması olmuş, teşekkür ederim. Hocam sizin yazdığınız makroyu ekte gönderdiğim dosyaya uyarlamaya çalıştım ama bu sefer istenilen sonuç iki adet olduğu için yapamadım, size zahmet bu dosyaya da bakabilir misiniz? Teşekkür ederim.

 

[Muhammet Okumuş]

Burada hangi 2 sayıyı bulmak istiyorsunuz? Manuel örnek ile açıklar mısınız?

 

[akmlyx]

Hocam, önce MOD((A2+C2+E2+G2+I2)*7-(B2+D2+F2+H2);10) formülü ile J2 hücresindeki sıfırı, sonra MOD(TOPLA(A2:J2);10) formülü ile K2 hücresindeki 4 rakamını bulmak istiyor en son da bu kurala uygun olan A2 ile K2 hücreler arasındaki 11 basamaklı sayıyı L2 hücresinden itibaren listelenmesini istiyorum.

 

[Muhammet Okumuş]

Her zaman 0 ve 4 ü mü bulacak? Bu değerler sabit mi?

 

[akmlyx]

Hayır hocam, 0 ve 4 örnek, değerler manuel giriş yapılacak olup değişkendir.

 

[Muhammet Okumuş]

Ama bu çok uzun sürer. 1.000.000.000 bu kadar döngü demek.

 

[Muhammet Okumuş]

Sub Bul()
Application.ScreenUpdating = False
Dim a, b, c, d, e, f, g, h, i, hdf, hdf2 As Byte, n As Long, tablo As Variant
Range("L2:L10000").ClearContents
hdf = Range("J2").Value
hdf2 = Range("K2").Value
If hdf > 9 Or Not IsNumeric(hdf) Then Exit Sub
ReDim tablo(1 To 1000, 1 To 1)

For a = 0 To 9
For b = 0 To 9
For c = 0 To 9
For d = 0 To 9
For e = 0 To 9
For f = 0 To 9
For g = 0 To 9
For h = 0 To 9
For i = 0 To 9

If (((a + c + e + g + i) * 7) - (b + d + f + h)) Mod 10 = hdf And a + b + c + d + e + f + g + h + i Mod 10 = hdf2 Then
n = n + 1
tablo(n, 1) = a & b & c & d & e & f & g & h & i
End If

Next
Next
Next
Next
Next
Next
Next
Next
Next

If n = 0 Then Exit Sub
Range("L2").Resize(n, 1) = tablo
End Sub

Diziyi 1000 ile sınırlandırdım. Eğer kriterlere uyan sayı 1000i geçerse hata verir.