Makro ile Kombinasyon Oluşturma

U

uewhes

Katılım
7 Haziran 2022
Mesajlar
8
Excel Vers. ve Dili
2010
Merhaba,
Excel görünümüm tahmini olarak aşağıdaki gibi olacaktır.

-------A----B----C----D----E----F
1--------------------------------35
2--------------------------------100
3---------------------------------84
4---------------------------------90
5---------------------------------36
6---------------------------------44
7---------------------------------25
8---------------------------------39
9---------------------------------72
10--------------------------------73

Amaç: buton yardımı ile ilk olarak bana "Modül Numarası Giriniz" şeklinde kutu açılıp rakam olarak girdi yapmamı isteyecek. Girmiş olduğum numarayı da aşağıdaki formulü uygulayarak girmiş olduğum modül değerine uygun kombinasyonu belirleyecek. Uygun kombinasyonlar için sayılar F satırı altındaki numaralardan seçilecek. Girmiş olduğum değere en yakın sonuca göre A1, A2, A3, A4 değerlerini bana message box olarak bildirecek.
Formül : (((A1)*(A2))/ ((A3)*(A4)))*3 = "girilen modül değeri" (eşitliği tam olarak sağlayamasa bile virgülden sonraki 4 veya 5 haneye kadar sağladığında eşit kabul edilecek)
Örnek : modül değeri 0,5 olsun.. F satırındaki numaraları uygun kombinasyonla A1, A2, A3, A4 e yerleştirip. Formulü uygulayıp ((35*36)/(84*90))*3 = 0,5 gibi. Ardından message box da A1=35 , A2=36 , A3=84 VE A4=90 mesajı gözükmeli.
Yardımcı olabilirseniz sevinirim.
Maalesef dosya yükleyemiyorum "-" ön izlemede düzgün gözüksün diye konuldu.
 
U

uewhes

Katılım
7 Haziran 2022
Mesajlar
8
Excel Vers. ve Dili
2010
Eklemeyi unutmuşum :) A1 61 değerinden küçük olmalı ve F satırındaki her bir sayı bir kere kullanılabilecek
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Merhaba.

Dner misiniz?
Kod: 
Sub test()
    Dim R As Range
    Dim A As Byte, B As Byte, C As Byte, D As Byte
    Dim Aranan As Double
    Dim Sonuc As Double
    Dim Fark As Double
    Aranan = InputBox("Lütfen değer giriniz.")
    Fark = 1000
    Set R = Range("F1:F10")
        For A = 1 To 10
            For B = 1 To 10
                If B = A Then
                    B = B + 1
                    If B > 10 Then
                        B = 1
                        GoTo TekrarA
                    End If
                    GoTo TekrarB
                End If
                For C = 1 To 10
                    If C = A Or C = B Then
                        C = C + 1
                        If C > 10 Then
                            C = 1
                            GoTo TekrarB
                        End If
                        GoTo TekrarC
                    End If
                    For D = 1 To 10
                        If D = A Or D = B Or D = C Then
                            D = D + 1
                            If D > 10 Then
                                D = 1
                                GoTo TekrarC
                            End If
                            GoTo TekrarD
                        End If
                        
                        If R(A, 1) < 61 Then
                            Sonuc = (R(A, 1) * R(B, 1)) / (R(C, 1) * R(D, 1)) * 3
                            If Aranan = Sonuc Then
                                Range("A1") = R(A, 1)
                                Range("A2") = R(B, 1)
                                Range("A3") = R(C, 1)
                                Range("A4") = R(D, 1)
                                GoTo Esitlik
                            Else
                                If Abs(Sonuc - Aranan) < Fark Then
                                    Fark = Abs(Sonuc - Aranan)
                                    Range("A1") = R(A, 1)
                                    Range("A2") = R(B, 1)
                                    Range("A3") = R(C, 1)
                                    Range("A4") = R(D, 1)
                                End If
                            End If
                        End If
TekrarD:
                    Next
TekrarC:
                Next
TekrarB:
            Next
TekrarA:
        Next
Esitlik:
        MsgBox Range("A1") & vbLf & Range("A2") & vbLf & Range("A3") & vbLf & Range("A4")
End Sub
 
U

uewhes

Katılım
7 Haziran 2022
Mesajlar
8
Excel Vers. ve Dili
2010
Muzaffer Ali' Alıntı:
Merhaba.

Dner misiniz?
Kod: 
Sub test()
    Dim R As Range
    Dim A As Byte, B As Byte, C As Byte, D As Byte
    Dim Aranan As Double
    Dim Sonuc As Double
    Dim Fark As Double
    Aranan = InputBox("Lütfen değer giriniz.")
    Fark = 1000
    Set R = Range("F1:F10")
        For A = 1 To 10
            For B = 1 To 10
                If B = A Then
                    B = B + 1
                    If B > 10 Then
                        B = 1
                        GoTo TekrarA
                    End If
                    GoTo TekrarB
                End If
                For C = 1 To 10
                    If C = A Or C = B Then
                        C = C + 1
                        If C > 10 Then
                            C = 1
                            GoTo TekrarB
                        End If
                        GoTo TekrarC
                    End If
                    For D = 1 To 10
                        If D = A Or D = B Or D = C Then
                            D = D + 1
                            If D > 10 Then
                                D = 1
                                GoTo TekrarC
                            End If
                            GoTo TekrarD
                        End If
                       
                        If R(A, 1) < 61 Then
                            Sonuc = (R(A, 1) * R(B, 1)) / (R(C, 1) * R(D, 1)) * 3
                            If Aranan = Sonuc Then
                                Range("A1") = R(A, 1)
                                Range("A2") = R(B, 1)
                                Range("A3") = R(C, 1)
                                Range("A4") = R(D, 1)
                                GoTo Esitlik
                            Else
                                If Abs(Sonuc - Aranan) < Fark Then
                                    Fark = Abs(Sonuc - Aranan)
                                    Range("A1") = R(A, 1)
                                    Range("A2") = R(B, 1)
                                    Range("A3") = R(C, 1)
                                    Range("A4") = R(D, 1)
                                End If
                            End If
                        End If
TekrarD:
                    Next
TekrarC:
                Next
TekrarB:
            Next
TekrarA:
        Next
Esitlik:
        MsgBox Range("A1") & vbLf & Range("A2") & vbLf & Range("A3") & vbLf & Range("A4")
End Sub
Genişletmek için tıkla ...
Muzaffer Bey, ilk izlenimime göre makro çalışmakta, elimde olan değerler doğrultusunda emniyet açısından kontrol edeceğim. Bir sorunla karşılaşır isem sorun ile alakalı veya hiçbir sorun olmadığına dair sizlerle tekrardan iletişime geçerim.

İlginize çok teşekkür ediyorum :)
 
U

uewhes

Katılım
7 Haziran 2022
Mesajlar
8
Excel Vers. ve Dili
2010
Muzaffer Ali' Alıntı:
Rica ederim. Kolay gelsin.
Genişletmek için tıkla ...
Sub test()
Dim R As Range
Dim A As Byte, B As Byte, C As Byte, D As Byte
Dim Aranan As Double
Dim Sonuc As Double
Dim Fark As Double
Sorgula:
Aranan = Application.InputBox("Lütfen Hesaplanacak Modülü 0,5-7,0 aralığında giriniz!", "MODÜL SORGULAMA EKRANI")
If Aranan = False Then Exit Sub
If Aranan < 0.4999 Or Aranan > 7.001 Then
Hata:
MsgBox no & "Belirtilen değer aralığı dışında bir değer girdiniz!", vbCritical, ""
GoTo Sorgula

ElseIf Aranan > 0.4999 Or Aranan < 7.001 Then
Fark = 1000000

Muzaffer Bey merhaba,
Kodun başlangıcını bu şekilde yaptım. Fakat Inputbox a girilen değer sayı değilse hata veriyor makro. Ben sayı dışında bir şey girildiğinde kodu Hata ya götürsün istiyorum.
Ayrıca Aranan <0,4999 yapmış olmama rağmen değere 0 yazınca Sanki InputBox a CANCEL demişim gibi kapatıyor sorgulama ekranını. 0 yazıldığında da yine beni Hata ya götürsün istiyorum.

Yardımcı olabilir misiniz.
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Deneyiniz.
Kod: 
Sub test()
    Dim R As Range
    Dim A As Byte, b As Byte, C As Byte, D As Byte
    Dim Aranan As String
    Dim Sonuc As Double
    Dim Fark As Double
Sorgula:
    Aranan = Application.InputBox("Lütfen Hesaplanacak Modülü 0,5-7,0 aralığında giriniz!", "MODÜL SORGULAMA EKRANI")
    
    If Aranan = "" Then
        MsgBox "İptal edildi."
        Exit Sub
    End If
    
    If Not IsNumeric(Aranan) Then
        MsgBox "Buraya sadece 0,5-7,0 aralığı içinde bir rakam girişi yapabilirsiniz! Lütfen tekrar deneyiniz.", vbCritical, ""
       GoTo Sorgula
    End If
    
    If Aranan < 0.5 Or Aranan > 7 Then
        MsgBox "0,5-7,0 aralığı dışında bir değer girdiniz! Lütfen tekrar deneyiniz.", vbCritical, ""
        GoTo Sorgula
    End If

    Fark = 1000
    Set R = Range("F1:F10")
        For A = 1 To 10
            For b = 1 To 10
                If b = A Then
                    b = b + 1
                    If b > 10 Then
                        b = 1
                        GoTo TekrarA
                    End If
                    GoTo TekrarB
                End If
                For C = 1 To 10
                    If C = A Or C = b Then
                        C = C + 1
                        If C > 10 Then
                            C = 1
                            GoTo TekrarB
                        End If
                        GoTo TekrarC
                    End If
                    For D = 1 To 10
                        If D = A Or D = b Or D = C Then
                            D = D + 1
                            If D > 10 Then
                                D = 1
                                GoTo TekrarC
                            End If
                            GoTo TekrarD
                        End If
                        
                        If R(A, 1) < 61 Then
                            Sonuc = (R(A, 1) * R(b, 1)) / (R(C, 1) * R(D, 1)) * 3
                            If Aranan = Sonuc Then
                                Range("A1") = R(A, 1)
                                Range("A2") = R(b, 1)
                                Range("A3") = R(C, 1)
                                Range("A4") = R(D, 1)
                                GoTo Esitlik
                            Else
                                If Abs(Sonuc - Aranan) < Fark Then
                                    Fark = Abs(Sonuc - Aranan)
                                    Range("A1") = R(A, 1)
                                    Range("A2") = R(b, 1)
                                    Range("A3") = R(C, 1)
                                    Range("A4") = R(D, 1)
                                End If
                            End If
                        End If
TekrarD:
                    Next
TekrarC:
                Next
TekrarB:
            Next
TekrarA:
        Next
Esitlik:
        MsgBox Range("A1") & vbLf & Range("A2") & vbLf & Range("A3") & vbLf & Range("A4")
End Sub
 
U

uewhes

Katılım
7 Haziran 2022
Mesajlar
8
Excel Vers. ve Dili
2010
Muzaffer Ali' Alıntı:
Deneyiniz.
Kod: 
Sub test()
    Dim R As Range
    Dim A As Byte, b As Byte, C As Byte, D As Byte
    Dim Aranan As String
    Dim Sonuc As Double
    Dim Fark As Double
Sorgula:
    Aranan = Application.InputBox("Lütfen Hesaplanacak Modülü 0,5-7,0 aralığında giriniz!", "MODÜL SORGULAMA EKRANI")
   
    If Aranan = "" Then
        MsgBox "İptal edildi."
        Exit Sub
    End If
   
    If Not IsNumeric(Aranan) Then
        MsgBox "Buraya sadece 0,5-7,0 aralığı içinde bir rakam girişi yapabilirsiniz! Lütfen tekrar deneyiniz.", vbCritical, ""
       GoTo Sorgula
    End If
   
    If Aranan < 0.5 Or Aranan > 7 Then
        MsgBox "0,5-7,0 aralığı dışında bir değer girdiniz! Lütfen tekrar deneyiniz.", vbCritical, ""
        GoTo Sorgula
    End If

    Fark = 1000
    Set R = Range("F1:F10")
        For A = 1 To 10
            For b = 1 To 10
                If b = A Then
                    b = b + 1
                    If b > 10 Then
                        b = 1
                        GoTo TekrarA
                    End If
                    GoTo TekrarB
                End If
                For C = 1 To 10
                    If C = A Or C = b Then
                        C = C + 1
                        If C > 10 Then
                            C = 1
                            GoTo TekrarB
                        End If
                        GoTo TekrarC
                    End If
                    For D = 1 To 10
                        If D = A Or D = b Or D = C Then
                            D = D + 1
                            If D > 10 Then
                                D = 1
                                GoTo TekrarC
                            End If
                            GoTo TekrarD
                        End If
                       
                        If R(A, 1) < 61 Then
                            Sonuc = (R(A, 1) * R(b, 1)) / (R(C, 1) * R(D, 1)) * 3
                            If Aranan = Sonuc Then
                                Range("A1") = R(A, 1)
                                Range("A2") = R(b, 1)
                                Range("A3") = R(C, 1)
                                Range("A4") = R(D, 1)
                                GoTo Esitlik
                            Else
                                If Abs(Sonuc - Aranan) < Fark Then
                                    Fark = Abs(Sonuc - Aranan)
                                    Range("A1") = R(A, 1)
                                    Range("A2") = R(b, 1)
                                    Range("A3") = R(C, 1)
                                    Range("A4") = R(D, 1)
                                End If
                            End If
                        End If
TekrarD:
                    Next
TekrarC:
                Next
TekrarB:
            Next
TekrarA:
        Next
Esitlik:
        MsgBox Range("A1") & vbLf & Range("A2") & vbLf & Range("A3") & vbLf & Range("A4")
End Sub
Genişletmek için tıkla ...
Muzaffer Bey denedim, Fakat
If Aranan = " " Then eşitliğinde hata veriyor
 
Muzaffer Ali

Muzaffer Ali

Destek Ekibi
Destek Ekibi
Katılım
5 Haziran 2006
Mesajlar
6,167
Excel Vers. ve Dili
2019 Türkçe
Önceklikle belirteyim doğrusu çift tırnaklar arasında boşluk olmamalı. Sizin son mesajınızda boşluk var görünüyor.
Kod: 
If Aranan = "" Then
Bir hata alıyorsanız nasıl bir hata aldığınızı da söylemelisiniz ki çözüm üretebilelim.

Hata aldığınız dosyayı da paylaşırsanız daha hızlı çözüm bulabiliriz.
Dosyanızı bir paylaşım sitesi ile paylaşabilirsiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst