belirli hücrelere belirlenen aralıktaki sayıları karışık getirme

farisakboga · 29 Ekim 2022

örnek dosyada belirlediğim c4, g4, k4,c9, g9, k9,c14, g14, k14,c19, g19, k19,c24, g24, k24 hücrelerine kod ile 1'den 15'e kadar olan sayıların karışık gelmesini istiyorum. Makroyu bir düğmeye tanımlayıp her çalıştırdığımda 1'den 15'e kadar olan sayıların yeri değişsin. Bunu nasıl bir kod ile gerçekleştirebilirim?

Korhan Ayhan · 30 Ekim 2022

Deneyiniz.

C++:

Option Explicit

Sub Rastgele()
    Dim My_Area As Range, Rng As Range
    Dim My_Number As Byte, Number_Array As Variant
    Dim My_Array As Object, X As Byte
    
    Set My_Area = Union(Range("C4"), Range("G4"), Range("K4"), _
                     Range("C9"), Range("G9"), Range("K9"), _
                     Range("C14"), Range("G14"), Range("K14"), _
                     Range("C19"), Range("G19"), Range("K19"), _
                     Range("C24"), Range("G24"), Range("K24"))
        
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    
Repeat:
    Randomize Timer
    
    My_Number = WorksheetFunction.RandBetween(1, 15)
    
    If Not My_Array.Exists(My_Number) Then
        My_Array.Add My_Number, False
    End If
    
    If My_Array.Count < 15 Then GoTo Repeat
    
    Number_Array = My_Array.Keys
    
    For Each Rng In My_Area
        Rng.Value = Number_Array(X)
        X = X + 1
    Next

    Set My_Array = Nothing
    Set My_Area = Nothing

    MsgBox "Sayılar rastgele dizilmiştir."
End Sub

farisakboga · 30 Ekim 2022

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Rastgele()
    Dim My_Area As Range, Rng As Range
    Dim My_Number As Byte, Number_Array As Variant
    Dim My_Array As Object, X As Byte
  
    Set My_Area = Union(Range("C4"), Range("G4"), Range("K4"), _
                     Range("C9"), Range("G9"), Range("K9"), _
                     Range("C14"), Range("G14"), Range("K14"), _
                     Range("C19"), Range("G19"), Range("K19"), _
                     Range("C24"), Range("G24"), Range("K24"))
      
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
  
Repeat:
    Randomize Timer
  
    My_Number = WorksheetFunction.RandBetween(1, 15)
  
    If Not My_Array.Exists(My_Number) Then
        My_Array.Add My_Number, False
    End If
  
    If My_Array.Count < 15 Then GoTo Repeat
  
    Number_Array = My_Array.Keys
  
    For Each Rng In My_Area
        Rng.Value = Number_Array(X)
        X = X + 1
    Next

    Set My_Array = Nothing
    Set My_Area = Nothing

    MsgBox "Sayılar rastgele dizilmiştir."
End Sub

Çok teşekkür ederim. kod harika çalışıyor.

My_Number = WorksheetFunction.RandBetween(1, 15)

bu aralığı örneğin 101 ile 115 arası yaptığımda kod çalışmıyor. koda sayı aralığı esnekliği katmam için başka nereyi değiştirmem gerekiyor?

If My_Array.Count < 15 Then GoTo Repeat

burayı <115 olarak değiştirdim yine olmadı.

Korhan Ayhan · 30 Ekim 2022

Numaraların değişken olacağını ilk mesajınızda belirtmemişsiniz.

Deneyiniz.

C++:

Option Explicit

Sub Rastgele()
    Dim My_Area As Range, Rng As Range
    Dim My_Number As Byte, Number_Array As Variant
    Dim My_Array As Object, X As Byte
    Dim First_Number As Integer, Last_Number As Integer
    
    Set My_Area = Union(Range("C4"), Range("G4"), Range("K4"), _
                     Range("C9"), Range("G9"), Range("K9"), _
                     Range("C14"), Range("G14"), Range("K14"), _
                     Range("C19"), Range("G19"), Range("K19"), _
                     Range("C24"), Range("G24"), Range("K24"))
        
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    
Repeat:
    Randomize Timer
    
    First_Number = 101
    Last_Number = 115
    
    My_Number = WorksheetFunction.RandBetween(First_Number, Last_Number)
    
    If Not My_Array.Exists(My_Number) Then
        My_Array.Add My_Number, False
    End If
    
    If My_Array.Count < (Last_Number - First_Number + 1) Then GoTo Repeat
    
    Number_Array = My_Array.Keys
    
    For Each Rng In My_Area
        Rng.Value = Number_Array(X)
        X = X + 1
    Next

    Set My_Array = Nothing
    Set My_Area = Nothing

    MsgBox "Sayılar rastgele dizilmiştir."
End Sub

farisakboga · 30 Ekim 2022

Korhan Ayhan' Alıntı:

Numaraların değişken olacağını ilk mesajınızda belirtmemişsiniz.

Deneyiniz.

C++:

Option Explicit

Sub Rastgele()
    Dim My_Area As Range, Rng As Range
    Dim My_Number As Byte, Number_Array As Variant
    Dim My_Array As Object, X As Byte
    Dim First_Number As Integer, Last_Number As Integer
   
    Set My_Area = Union(Range("C4"), Range("G4"), Range("K4"), _
                     Range("C9"), Range("G9"), Range("K9"), _
                     Range("C14"), Range("G14"), Range("K14"), _
                     Range("C19"), Range("G19"), Range("K19"), _
                     Range("C24"), Range("G24"), Range("K24"))
       
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
   
Repeat:
    Randomize Timer
   
    First_Number = 101
    Last_Number = 115
   
    My_Number = WorksheetFunction.RandBetween(First_Number, Last_Number)
   
    If Not My_Array.Exists(My_Number) Then
        My_Array.Add My_Number, False
    End If
   
    If My_Array.Count < (Last_Number - First_Number + 1) Then GoTo Repeat
   
    Number_Array = My_Array.Keys
   
    For Each Rng In My_Area
        Rng.Value = Number_Array(X)
        X = X + 1
    Next

    Set My_Array = Nothing
    Set My_Area = Nothing

    MsgBox "Sayılar rastgele dizilmiştir."
End Sub

Siteminizde gayet haklısınız. Buna rağmen tekrar yardımcı oldunuz. Çok teşekkür ederim.

farisakboga · 5 Kasım 2022

Korhan Ayhan' Alıntı:

Numaraların değişken olacağını ilk mesajınızda belirtmemişsiniz.

Deneyiniz.

C++:

Option Explicit

Sub Rastgele()
    Dim My_Area As Range, Rng As Range
    Dim My_Number As Byte, Number_Array As Variant
    Dim My_Array As Object, X As Byte
    Dim First_Number As Integer, Last_Number As Integer
   
    Set My_Area = Union(Range("C4"), Range("G4"), Range("K4"), _
                     Range("C9"), Range("G9"), Range("K9"), _
                     Range("C14"), Range("G14"), Range("K14"), _
                     Range("C19"), Range("G19"), Range("K19"), _
                     Range("C24"), Range("G24"), Range("K24"))
       
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
   
Repeat:
    Randomize Timer
   
    First_Number = 101
    Last_Number = 115
   
    My_Number = WorksheetFunction.RandBetween(First_Number, Last_Number)
   
    If Not My_Array.Exists(My_Number) Then
        My_Array.Add My_Number, False
    End If
   
    If My_Array.Count < (Last_Number - First_Number + 1) Then GoTo Repeat
   
    Number_Array = My_Array.Keys
   
    For Each Rng In My_Area
        Rng.Value = Number_Array(X)
        X = X + 1
    Next

    Set My_Array = Nothing
    Set My_Area = Nothing

    MsgBox "Sayılar rastgele dizilmiştir."
End Sub

Merhaba Korhan bey! Aynı mantıkla rastgele tekrarsız sayı dağıtma yerine sayfa2'de A sütununda bulunan örneğin 80 kelimeyi Sayafa1'de belirlediğim alana rastgele benzersiz dağıtabilir miyiz? Yani sayılar yerine kelimeler yer değiştirecek. Yardımcı olmanız mümkün mü?

Korhan Ayhan · 5 Kasım 2022

Örnek dosyanızı paylaşırsanız yardımcı olmaya çalışırım.

farisakboga · 5 Kasım 2022

Korhan Ayhan' Alıntı:
Örnek dosyanızı paylaşırsanız yardımcı olmaya çalışırım.

Çok teşekkür ederim. Örnek dosyayı ekledim. İçinde açıklama da var.

Korhan Ayhan · 5 Kasım 2022

Deneyiniz.

C++:

Option Explicit

Sub Rastgele()
    Dim WS1 As Worksheet, WS2 As Worksheet
    Dim My_Area As Range, Rng As Range, My_Data As Range
    Dim My_Number As Byte, Number_Array As Variant
    Dim My_Array As Object, X As Byte, My_CountBlank As Long
    Dim First_Number As Integer, Last_Number As Integer
    
    Set WS1 = Sheets("Sayfa1")
    Set WS2 = Sheets("Sayfa2")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
    
    Set My_Area = WS1.Range("A1:G10")
    Set My_Data = WS2.Range("A1:A" & WS2.Cells(WS2.Rows.Count, 1).End(3).Row)
        
    My_CountBlank = WorksheetFunction.CountBlank(My_Data)
    
    My_Area.ClearContents
    
    If My_Area.Cells.Count > (My_Data.Cells.Count - My_CountBlank) Then
        MsgBox "Kelime listesi ile verilerin listeleneceği hücre sayısı eşit değil lütfen kontrol ediniz!", vbCritical
        Exit Sub
    End If
    
Repeat:
    Randomize Timer
    
    First_Number = 1
    Last_Number = WS2.Cells(WS2.Rows.Count, 1).End(3).Row
    
    My_Number = WorksheetFunction.RandBetween(First_Number, Last_Number)
    
    If Not My_Array.Exists(My_Number) Then
        If WS2.Cells(My_Number, 1) <> "" Then
            My_Array.Add My_Number, False
        End If
    End If
    
    If My_Array.Count < (Last_Number - First_Number - My_CountBlank + 1) Then GoTo Repeat
    
    Number_Array = My_Array.Keys
    
    For Each Rng In My_Area
        Rng.Value = WS2.Cells(Number_Array(X), 1)
        X = X + 1
    Next

    Set My_Array = Nothing
    Set My_Area = Nothing
    Set My_Data = Nothing
    Set WS1 = Nothing
    Set WS2 = Nothing

    MsgBox "Kelimeler rastgele dizilmiştir."
End Sub

farisakboga · 5 Kasım 2022

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Rastgele()
    Dim WS1 As Worksheet, WS2 As Worksheet
    Dim My_Area As Range, Rng As Range, My_Data As Range
    Dim My_Number As Byte, Number_Array As Variant
    Dim My_Array As Object, X As Byte, My_CountBlank As Long
    Dim First_Number As Integer, Last_Number As Integer
   
    Set WS1 = Sheets("Sayfa1")
    Set WS2 = Sheets("Sayfa2")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
   
    Set My_Area = WS1.Range("A1:G10")
    Set My_Data = WS2.Range("A1:A" & WS2.Cells(WS2.Rows.Count, 1).End(3).Row)
       
    My_CountBlank = WorksheetFunction.CountBlank(My_Data)
   
    My_Area.ClearContents
   
    If My_Area.Cells.Count > (My_Data.Cells.Count - My_CountBlank) Then
        MsgBox "Kelime listesi ile verilerin listeleneceği hücre sayısı eşit değil lütfen kontrol ediniz!", vbCritical
        Exit Sub
    End If
   
Repeat:
    Randomize Timer
   
    First_Number = 1
    Last_Number = WS2.Cells(WS2.Rows.Count, 1).End(3).Row
   
    My_Number = WorksheetFunction.RandBetween(First_Number, Last_Number)
   
    If Not My_Array.Exists(My_Number) Then
        If WS2.Cells(My_Number, 1) <> "" Then
            My_Array.Add My_Number, False
        End If
    End If
   
    If My_Array.Count < (Last_Number - First_Number - My_CountBlank + 1) Then GoTo Repeat
   
    Number_Array = My_Array.Keys
   
    For Each Rng In My_Area
        Rng.Value = WS2.Cells(Number_Array(X), 1)
        X = X + 1
    Next

    Set My_Array = Nothing
    Set My_Area = Nothing
    Set My_Data = Nothing
    Set WS1 = Nothing
    Set WS2 = Nothing

    MsgBox "Kelimeler rastgele dizilmiştir."
End Sub

Çok teşekkür ederim. Tam istediğim gibi olmuş. Elinize, yüreğinize sağlık.

farisakboga · 1 Ocak 2023

Korhan Ayhan' Alıntı:

Deneyiniz.

C++:

Option Explicit

Sub Rastgele()
    Dim WS1 As Worksheet, WS2 As Worksheet
    Dim My_Area As Range, Rng As Range, My_Data As Range
    Dim My_Number As Byte, Number_Array As Variant
    Dim My_Array As Object, X As Byte, My_CountBlank As Long
    Dim First_Number As Integer, Last_Number As Integer
   
    Set WS1 = Sheets("Sayfa1")
    Set WS2 = Sheets("Sayfa2")
    Set My_Array = VBA.CreateObject("Scripting.Dictionary")
   
    Set My_Area = WS1.Range("A1:G10")
    Set My_Data = WS2.Range("A1:A" & WS2.Cells(WS2.Rows.Count, 1).End(3).Row)
       
    My_CountBlank = WorksheetFunction.CountBlank(My_Data)
   
    My_Area.ClearContents
   
    If My_Area.Cells.Count > (My_Data.Cells.Count - My_CountBlank) Then
        MsgBox "Kelime listesi ile verilerin listeleneceği hücre sayısı eşit değil lütfen kontrol ediniz!", vbCritical
        Exit Sub
    End If
   
Repeat:
    Randomize Timer
   
    First_Number = 1
    Last_Number = WS2.Cells(WS2.Rows.Count, 1).End(3).Row
   
    My_Number = WorksheetFunction.RandBetween(First_Number, Last_Number)
   
    If Not My_Array.Exists(My_Number) Then
        If WS2.Cells(My_Number, 1) <> "" Then
            My_Array.Add My_Number, False
        End If
    End If
   
    If My_Array.Count < (Last_Number - First_Number - My_CountBlank + 1) Then GoTo Repeat
   
    Number_Array = My_Array.Keys
   
    For Each Rng In My_Area
        Rng.Value = WS2.Cells(Number_Array(X), 1)
        X = X + 1
    Next

    Set My_Array = Nothing
    Set My_Area = Nothing
    Set My_Data = Nothing
    Set WS1 = Nothing
    Set WS2 = Nothing

    MsgBox "Kelimeler rastgele dizilmiştir."
End Sub

Merhaba Korhan Bey! Hazırladığınız yukarıdaki kodlardan çalışmalarımda oldukça faydalanıyorum. Ancak A sütununa yaklaşık 8000 adet kelime girdiğimde overflow diye bir hata veriyor. Sayıyı 200 civarına indirdiğimce kod çalışıyor. Bununla ilgili yardımcı olabilir misiniz?

ÖmerFaruk · 1 Ocak 2023

Kodların değişken tanımlama kısmındaki aşağıdaki satırı gösterdiğim gibi değiştirip dener misin.
Dim My_Number As Byte, Number_Array As Variant
Dim My_Number As Integer, Number_Array As Variant

farisakboga · 1 Ocak 2023

Bir de şu var.

Set My_Area = WS1.Range("A1:G10")

bu kodda oynama yaparak satır-sütun aralığı belirleyebiliyorum. Ancak bunu biraz esnetebilir miyiz? Örneğin b2-f2 aralığına gelsin. 3,4,5 satırı boş b6-f6 aralığına gelsin. Yani aralıkları kendimiz belirleyebilir miyiz?

farisakboga · 1 Ocak 2023

ÖmerFaruk' Alıntı:
Kodların değişken tanımlama kısmındaki aşağıdaki satırı gösterdiğim gibi değiştirip dener misin.
Dim My_Number As Byte, Number_Array As Variant
Dim My_Number As Integer, Number_Array As Variant

Teşekkür ederim. Çalışıyor.

Korhan Ayhan · 1 Ocak 2023

İlgili tanımlamada #2 nolu mesajdaki örnek yapıyı kullanabilirsiniz.

farisakboga · 1 Ocak 2023

Korhan Ayhan' Alıntı:
İlgili tanımlamada #2 nolu mesajdaki örnek yapıyı kullanabilirsiniz.

Set My_Area = Union(Range("C4"), Range("G4"), Range("K4"), _
Range("C9"), Range("G9"), Range("K9"), _
Range("C14"), Range("G14"), Range("K14"), _
Range("C19"), Range("G19"), Range("K19"), _
Range("C24"), Range("G24"), Range("K24"))

burası sanırım. teşekkür ederim.

belirli hücrelere belirlenen aralıktaki sayıları karışık getirme

farisakboga

Ekli dosyalar

Korhan Ayhan

Administrator

farisakboga

Korhan Ayhan

Administrator

farisakboga

farisakboga

Korhan Ayhan

Administrator

farisakboga

Ekli dosyalar

Korhan Ayhan

Administrator

farisakboga

farisakboga

ÖmerFaruk

Destek Ekibi

farisakboga

farisakboga

Korhan Ayhan

Administrator

farisakboga