RASTGELE SAYILARI KOŞULA GÖRE DEĞİŞTİRME

F

farisakboga

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
161
Excel Vers. ve Dili
Excel 2019 64 bit Tr
Altın Üyelik Bitiş Tarihi
29-04-2025
7 4 7 6 1 0 4 6

ÜSTTE RASTGELE ATANAN SAYILAR AŞAĞIDAKİ ŞARTLARDAN BİRİNİ SAĞLADIKLARINDA BELİRTİLEN SAYILAR İLE DEĞİŞSİNLER. BU DEĞİŞİMİ MAKRO İLE NASIL YAPABİLİRİZ? DEĞİŞİM SADECE BİR KEZ OLACAK. YANİ RASTGELE SAYILARDAN 3 VEYA 4 TANESİ KOŞULA UYGUN OLSA BİLE İŞLEM SADECE 2 SAYI İLE VE BİR KEZ YAPILSIN. KOŞULLARI DA RASTGELE KONTROL ETSİN.

EĞER 6 VE 9 VARSA 6 SAYISI 5'E, 9 SAYISI 8'E DÖNÜŞSÜN.

EĞER 6 VE 5 VARSA 6 SAYISI 5'E, 5 SAYISI 9'A DÖNÜŞSÜN.

EĞER 6 VE 3 VARSA 6 SAYISI 5'E, 3 SAYISI 9'A DÖNÜŞSÜN.

EĞER 6 VE 7 VARSA 6 SAYISI 8'E, 7 SAYISI 1'E DÖNÜŞSÜN.

EĞER 6 VE 0 VARSA 6 SAYISI 5'E, 0 SAYISI 8'E DÖNÜŞSÜN.

ÖRNEK DOSYA EKTEDİR.
 

Ekli dosyalar

Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,250
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

İkinci koşulunuzda 6 sayısı 5'e dönüşsün ve akabinde 5 sayısı 9'a dönüşsün demişsiniz. Bu durumda bu koşul sonunda bütün 5 sayıları 9'a dönüşecektir. Bunu önlemek için ilk olarak 5'leri 9'a dönüştürüp daha sonrasında 6'ları 5'e dönüştürdüm.

Kod: 
Option Explicit

Sub rastgele_sayi()
    [B5] = WorksheetFunction.RandBetween(1, 9)
    [C5] = WorksheetFunction.RandBetween(0, 9)
    [D5] = WorksheetFunction.RandBetween(1, 9)
    [E5] = WorksheetFunction.RandBetween(0, 9)
    [F5] = WorksheetFunction.RandBetween(1, 9)
    [G5] = WorksheetFunction.RandBetween(0, 9)
    [H5] = WorksheetFunction.RandBetween(1, 9)
    [I5] = WorksheetFunction.RandBetween(0, 9)
    Degistir
End Sub

Sub Degistir()
    Dim Alan As Range, WF As WorksheetFunction, Sayi As Byte, Bul As Range
    
    Set Alan = Range("B5:I5")
    Set WF = WorksheetFunction
    
    Alan.Interior.ColorIndex = xlNone
    
    Randomize Timer
    Sayi = WF.RandBetween(1, 5)
    
    Select Case Sayi
        Case 1
            If WF.CountIf(Alan, 6) > 0 And WF.CountIf(Alan, 9) > 0 Then
                If WF.CountIf(Alan, 6) = 1 Then
                    Set Bul = Alan.Find(6, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 5
                        Bul.Interior.ColorIndex = 6
                    End If
                Else
                    Set Bul = Alan.Find(6, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 5
                        Bul.Interior.ColorIndex = 6
                    End If
                End If
                If WF.CountIf(Alan, 9) = 1 Then
                    Set Bul = Alan.Find(9, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 8
                        Bul.Interior.ColorIndex = 6
                    End If
                Else
                    Set Bul = Alan.Find(9, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 8
                        Bul.Interior.ColorIndex = 6
                    End If
                End If
            End If
        Case 2
            If WF.CountIf(Alan, 6) > 0 And WF.CountIf(Alan, 5) > 0 Then
                If WF.CountIf(Alan, 6) = 1 Then
                    Set Bul = Alan.Find(6, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 5
                        Bul.Interior.ColorIndex = 6
                    End If
                Else
                    Set Bul = Alan.Find(6, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 5
                        Bul.Interior.ColorIndex = 6
                    End If
                End If
                If WF.CountIf(Alan, 5) = 1 Then
                    Set Bul = Alan.Find(5, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 9
                        Bul.Interior.ColorIndex = 6
                    End If
                Else
                    Set Bul = Alan.Find(5, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 9
                        Bul.Interior.ColorIndex = 6
                    End If
                End If
            End If
        Case 3
            If WF.CountIf(Alan, 6) > 0 And WF.CountIf(Alan, 3) > 0 Then
                If WF.CountIf(Alan, 6) = 1 Then
                    Set Bul = Alan.Find(6, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 5
                        Bul.Interior.ColorIndex = 6
                    End If
                Else
                    Set Bul = Alan.Find(6, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 5
                        Bul.Interior.ColorIndex = 6
                    End If
                End If
                If WF.CountIf(Alan, 3) = 1 Then
                    Set Bul = Alan.Find(3, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 9
                        Bul.Interior.ColorIndex = 6
                    End If
                Else
                    Set Bul = Alan.Find(3, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 9
                        Bul.Interior.ColorIndex = 6
                    End If
                End If
            End If
        Case 4
            If WF.CountIf(Alan, 6) > 0 And WF.CountIf(Alan, 7) > 0 Then
                If WF.CountIf(Alan, 6) = 1 Then
                    Set Bul = Alan.Find(6, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 8
                        Bul.Interior.ColorIndex = 6
                    End If
                Else
                    Set Bul = Alan.Find(6, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 8
                        Bul.Interior.ColorIndex = 6
                    End If
                End If
                If WF.CountIf(Alan, 7) = 1 Then
                    Set Bul = Alan.Find(7, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 1
                        Bul.Interior.ColorIndex = 6
                    End If
                Else
                    Set Bul = Alan.Find(7, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 1
                        Bul.Interior.ColorIndex = 6
                    End If
                End If
            End If
        Case 5
            If WF.CountIf(Alan, 6) > 0 And WF.CountIf(Alan, 0) > 0 Then
                If WF.CountIf(Alan, 6) = 1 Then
                    Set Bul = Alan.Find(6, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 5
                        Bul.Interior.ColorIndex = 6
                    End If
                Else
                    Set Bul = Alan.Find(6, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 5
                        Bul.Interior.ColorIndex = 6
                    End If
                End If
                If WF.CountIf(Alan, 0) = 1 Then
                    Set Bul = Alan.Find(0, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 8
                        Bul.Interior.ColorIndex = 6
                    End If
                Else
                    Set Bul = Alan.Find(0, , , xlWhole)
                    If Not Bul Is Nothing Then
                        Bul.Value = 8
                        Bul.Interior.ColorIndex = 6
                    End If
                End If
            End If
    End Select
End Sub
 
F

farisakboga

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
161
Excel Vers. ve Dili
Excel 2019 64 bit Tr
Altın Üyelik Bitiş Tarihi
29-04-2025
Korhan Ayhan' Alıntı:
Merhaba,

İkinci koşulunuzda 6 sayısı 5'e dönüşsün ve akabinde 5 sayısı 9'a dönüşsün demişsiniz. Bu durumda bu koşul sonunda bütün 5 sayıları 9'a dönüşecektir. Bunu önlemek için ilk olarak 5'leri 9'a dönüştürüp daha sonrasında 6'ları 5'e dönüştürdüm.

Kod: 
Sub rastgele_sayi()
    [B5] = WorksheetFunction.RandBetween(1, 9)
    [C5] = WorksheetFunction.RandBetween(0, 9)
    [D5] = WorksheetFunction.RandBetween(1, 9)
    [E5] = WorksheetFunction.RandBetween(0, 9)
    [F5] = WorksheetFunction.RandBetween(1, 9)
    [G5] = WorksheetFunction.RandBetween(0, 9)
    [H5] = WorksheetFunction.RandBetween(1, 9)
    [I5] = WorksheetFunction.RandBetween(0, 9)
    Degistir
End Sub

Sub Degistir()
    Dim Alan As Range, WF As WorksheetFunction, Sayi As Byte
   
    Set Alan = Range("B5:I5")
    Set WF = WorksheetFunction
   
    Sayi = WF.RandBetween(1, 5)
   
    Select Case Sayi
        Case 1
            If WF.CountIf(Alan, 6) > 0 And WF.CountIf(Alan, 9) > 0 Then
                Alan.Replace 6, 5, xlWhole
                Alan.Replace 9, 8, xlWhole
            End If
        Case 2
            If WF.CountIf(Alan, 6) > 0 And WF.CountIf(Alan, 5) > 0 Then
                Alan.Replace 5, 9, xlWhole
                Alan.Replace 6, 5, xlWhole
            End If
        Case 3
            If WF.CountIf(Alan, 6) > 0 And WF.CountIf(Alan, 3) > 0 Then
                Alan.Replace 6, 5, xlWhole
                Alan.Replace 3, 9, xlWhole
            End If
        Case 4
            If WF.CountIf(Alan, 6) > 0 And WF.CountIf(Alan, 7) > 0 Then
                Alan.Replace 6, 8, xlWhole
                Alan.Replace 7, 1, xlWhole
            End If
        Case 5
            If WF.CountIf(Alan, 6) > 0 And WF.CountIf(Alan, 0) > 0 Then
                Alan.Replace 6, 5, xlWhole
                Alan.Replace 0, 8, xlWhole
            End If
    End Select
End Sub
Genişletmek için tıkla ...
çok teşekkür ederim.
makro güzel çalışıyor ancak
6 5 3 9 6 7 3 5 (random gelen sayı)
5 5 9 9 5 7 8 5 (makro çalıştıktan sonra oluşan sayı)
renklendirdiğim 4 sayı değişmiş.
sadece 2 sayı değişsin. 2 sayı değiştikten sonra makro dursun.
bir de değiştirdiği sayıları kırmızı gösterebilir miyiz?
 
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
Kod: 
Sub rastgele_sayi()
    Range("B6:I6").Font.ColorIndex = xlAutomatic
    Range("B5:I6").ClearContents
    For i = 1 To 8
        Cells(5, i + 1).Value = WorksheetFunction.RandBetween(i Mod 2, 9)
    Next i
    lst = Range("B5:I5").Value
    If InStr(Join(Application.Index(lst, 0), ""), 6) > 0 Then
        For i = 1 To 8
            If lst(1, i) = 6 Then
                y6 = y6 & i
            Else
                Select Case lst(1, i)
                    Case 9, 5, 3, 7, 0: yD = yD & i
                End Select
            End If
        Next i
        If yD <> "" Then
            a = Mid(y6, WorksheetFunction.RandBetween(1, Len(y6)), 1)
            b = Mid(yD, WorksheetFunction.RandBetween(1, Len(yD)), 1)
            Select Case lst(1, b)
                Case 9, 0: lst(1, b) = 8: lst(1, a) = 5
                Case 5, 3: lst(1, b) = 9: lst(1, a) = 5
                Case 7: lst(1, b) = 1: lst(1, a) = 8
            End Select
            Cells(6, a + 1).Font.Color = vbRed
            Cells(6, b + 1).Font.Color = vbRed
        End If
    End If
    Range("B6:I6").Value = lst
End Sub
 
Son düzenleme:
F

farisakboga

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
161
Excel Vers. ve Dili
Excel 2019 64 bit Tr
Altın Üyelik Bitiş Tarihi
29-04-2025
veyselemre' Alıntı:
Kod: 
Sub rastgele_sayi()
    Range("B6:I6").Font.ColorIndex = xlAutomatic
    Range("B5:I6").ClearContents
    For i = 1 To 8
        Cells(5, i + 1).Value = WorksheetFunction.RandBetween(i Mod 2, 9)
    Next i
    lst = Range("B5:I5").Value
    tum = Join(Application.Index(lst, 0), "")
    Range("B6:I6").Font.ColorIndex = xlAutomatic
    If InStr(tum, 6) > 0 Then
        For i = 1 To 8
            If lst(1, i) = 6 Then
                y6 = y6 & i
            Else
                Select Case lst(1, i)
                    Case 9, 5, 3, 7, 0
                        yD = yD & i
                End Select
            End If
        Next i
        If yD <> "" Then
            yDsira = WorksheetFunction.RandBetween(1, Len(yD))
            y6sira = WorksheetFunction.RandBetween(1, Len(y6))
            a = Mid(y6, y6sira, 1)
            lst(1, a) = 5
            b = Mid(yD, yDsira, 1)
            Select Case lst(1, b)
                Case 9, 0: lst(1, b) = 8
                Case 5, 3: lst(1, b) = 9
                Case 7
                    lst(1, b) = 1
                    lst(1, a) = 8
            End Select
            Range("B6:I6").Value = lst
            Cells(6, a + 1).Font.Color = vbRed
            Cells(6, b + 1).Font.Color = vbRed
        End If
    End If
End Sub
Genişletmek için tıkla ...
teşekkür ederim.
 
F

farisakboga

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
161
Excel Vers. ve Dili
Excel 2019 64 bit Tr
Altın Üyelik Bitiş Tarihi
29-04-2025
veyselemre' Alıntı:
Kod: 
Sub rastgele_sayi()
    Range("B6:I6").Font.ColorIndex = xlAutomatic
    Range("B5:I6").ClearContents
    For i = 1 To 8
        Cells(5, i + 1).Value = WorksheetFunction.RandBetween(i Mod 2, 9)
    Next i
    lst = Range("B5:I5").Value
    If InStr(Join(Application.Index(lst, 0), ""), 6) > 0 Then
        For i = 1 To 8
            If lst(1, i) = 6 Then
                y6 = y6 & i
            Else
                Select Case lst(1, i)
                    Case 9, 5, 3, 7, 0: yD = yD & i
                End Select
            End If
        Next i
        If yD <> "" Then
            a = Mid(y6, WorksheetFunction.RandBetween(1, Len(y6)), 1)
            b = Mid(yD, WorksheetFunction.RandBetween(1, Len(yD)), 1)
            Select Case lst(1, b)
                Case 9, 0: lst(1, b) = 8: lst(1, a) = 5
                Case 5, 3: lst(1, b) = 9: lst(1, a) = 5
                Case 7: lst(1, b) = 1: lst(1, a) = 8
            End Select
            Cells(6, a + 1).Font.Color = vbRed
            Cells(6, b + 1).Font.Color = vbRed
        End If
    End If
    Range("B6:I6").Value = lst
End Sub
Genişletmek için tıkla ...
gayet güzel olmuş.
Ancak tüm işlemleri tek macro ile yapıyor.
rastgele sayı atamayı bir macro ile, değiştirmeyi de başka bir macro ile yapabilir miyiz?
yani 2 ayrı düğme olsun. biri sayı getirsin, diğer düğme belirttiğim şartlarda sayıları değiştirsin.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,250
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Üstteki mesajımdaki kodu güncelledim. Deneyiniz.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,250
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Üstteki mesajımdaki koda renklendirme özelliğide eklenmiştir.
 
veyselemre

veyselemre

Özel Üye
Katılım
9 Mart 2005
Mesajlar
3,646
Excel Vers. ve Dili
Pro Plus 2021
farisakboga' Alıntı:
gayet güzel olmuş.
Ancak tüm işlemleri tek macro ile yapıyor.
rastgele sayı atamayı bir macro ile, değiştirmeyi de başka bir macro ile yapabilir miyiz?
yani 2 ayrı düğme olsun. biri sayı getirsin, diğer düğme belirttiğim şartlarda sayıları değiştirsin.
Genişletmek için tıkla ...
Kod: 
Sub rastgele_sayi()
    Range("B5:I6").ClearContents
    For i = 1 To 8
        Cells(5, i + 1).Value = WorksheetFunction.RandBetween(i Mod 2, 9)
    Next i
End Sub
Sub duzenle()
    Range("B6:I6").Font.ColorIndex = xlAutomatic
    lst = Range("B5:I5").Value
    If InStr(Join(Application.Index(lst, 0), ""), 6) > 0 Then
        For i = 1 To 8
            If lst(1, i) = 6 Then
                y6 = y6 & i
            Else
                Select Case lst(1, i)
                    Case 9, 5, 3, 7, 0: yD = yD & i
                End Select
            End If
        Next i
        If yD <> "" Then
            a = Mid(y6, WorksheetFunction.RandBetween(1, Len(y6)), 1)
            b = Mid(yD, WorksheetFunction.RandBetween(1, Len(yD)), 1)
            Select Case lst(1, b)
                Case 9, 0: lst(1, b) = 8: lst(1, a) = 5
                Case 5, 3: lst(1, b) = 9: lst(1, a) = 5
                Case 7: lst(1, b) = 1: lst(1, a) = 8
            End Select
            Cells(6, a + 1).Font.Color = vbRed
            Cells(6, b + 1).Font.Color = vbRed
        End If
    End If
    Range("B6:I6").Value = lst
End Sub
 
F

farisakboga

Altın Üye
Katılım
26 Nisan 2019
Mesajlar
161
Excel Vers. ve Dili
Excel 2019 64 bit Tr
Altın Üyelik Bitiş Tarihi
29-04-2025
veyselemre' Alıntı:
Kod: 
Sub rastgele_sayi()
    Range("B5:I6").ClearContents
    For i = 1 To 8
        Cells(5, i + 1).Value = WorksheetFunction.RandBetween(i Mod 2, 9)
    Next i
End Sub
Sub duzenle()
    Range("B6:I6").Font.ColorIndex = xlAutomatic
    lst = Range("B5:I5").Value
    If InStr(Join(Application.Index(lst, 0), ""), 6) > 0 Then
        For i = 1 To 8
            If lst(1, i) = 6 Then
                y6 = y6 & i
            Else
                Select Case lst(1, i)
                    Case 9, 5, 3, 7, 0: yD = yD & i
                End Select
            End If
        Next i
        If yD <> "" Then
            a = Mid(y6, WorksheetFunction.RandBetween(1, Len(y6)), 1)
            b = Mid(yD, WorksheetFunction.RandBetween(1, Len(yD)), 1)
            Select Case lst(1, b)
                Case 9, 0: lst(1, b) = 8: lst(1, a) = 5
                Case 5, 3: lst(1, b) = 9: lst(1, a) = 5
                Case 7: lst(1, b) = 1: lst(1, a) = 8
            End Select
            Cells(6, a + 1).Font.Color = vbRed
            Cells(6, b + 1).Font.Color = vbRed
        End If
    End If
    Range("B6:I6").Value = lst
End Sub
Genişletmek için tıkla ...
çok teşekkür ederim. elinize sağlık.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst