Sütunda yazan değerlerin diğer sütuna karışık olarak yazdırılması ..

[pNouma]

Değerli Hocalarım merhaba,
Sayfada A sütununda yer alan yaklaşık 1000 satırda birbirinden farklı değerler yazılı;

yapmak istediğim "A" sütununda yazan bu değerleri rastgele(karışık) olarak B sütunundaki satırlara dağıtması,

Özetle A sütununda sıralı bir şekilde yazan değerleri B sütuna karışık olarak yazılması ...
Aşağıdaki kodda yer alan bir yöntem hazırladım ama burada A sütununda yazan bir değerin B sütununa birden çok defa daha yazılma ihtimali bulunuyor. Birde işlem çok uzun sürüyor.

Bunun daha pratik bir yöntemi var mıdır ? Yardımcı olursanız sevinirim.

Set SHT = Sayfa1
LR = SHT.Cells(SHT.Rows.Count, 1).End(xlUp).row

 SHT.Columns(2).ClearContents

For i = 2 To LR
      r= WorksheetFunction.RandBetween(2, LR)
      SHT.Cells(i, 2).Value = SHT.Cells(r, 1).Value
Next i

iyi Akşamlar.

 

[volki_112]

Değerli Hocalarım merhaba,
Sayfada A sütununda yer alan yaklaşık 1000 satırda birbirinden farklı değerler yazılı;

yapmak istediğim "A" sütununda yazan bu değerleri rastgele(karışık) olarak B sütunundaki satırlara dağıtması,

Özetle A sütununda sıralı bir şekilde yazan değerleri B sütuna karışık olarak yazılması ...
Aşağıdaki kodda yer alan bir yöntem hazırladım ama burada A sütununda yazan bir değerin B sütununa birden çok defa daha yazılma ihtimali bulunuyor. Birde işlem çok uzun sürüyor.

Bunun daha pratik bir yöntemi var mıdır ? Yardımcı olursanız sevinirim.

Set SHT = Sayfa1
LR = SHT.Cells(SHT.Rows.Count, 1).End(xlUp).row

SHT.Columns(2).ClearContents

For i = 2 To LR
      r= WorksheetFunction.RandBetween(2, LR)
      SHT.Cells(i, 2).Value = SHT.Cells(r, 1).Value
Next i

iyi Akşamlar.

istediğini kodlar.

Sub RastgeleSirala()

    Dim ws As Worksheet
    Dim sonSatir As Long
    Dim degerler As Variant
    Dim i As Long, j As Long, temp As Variant

    ' Çalışma sayfasını belirt (Sayfa1 yerine gerçek sayfa adınızı kullanın)
    Set ws = ThisWorkbook.Worksheets("Sayfa1")

    ' A sütunundaki son dolu satırı bul
    sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Değerleri bir diziye aktar
    degerler = ws.Range("A1:A" & sonSatir).Value

    ' Diziyi karıştır (Fisher-Yates algoritması)
    Randomize ' Rastgele sayı üreteciyi başlat
    For i = sonSatir To 2 Step -1
        j = Int((i * Rnd) + 1)
        temp = degerler(i, 1)
        degerler(i, 1) = degerler(j, 1)
        degerler(j, 1) = temp
    Next i

    ' B sütununu temizle (önceki verileri sil)
    ws.Range("B1:B" & sonSatir).ClearContents

    ' Karıştırılmış değerleri B sütununa yaz
    ws.Range("B1").Resize(sonSatir, 1).Value = degerler

    'Belleği temizle
    Set ws = Nothing

End Sub

 

[tamer42]

istediğini kodlar.

Sub RastgeleSirala()

    Dim ws As Worksheet
    Dim sonSatir As Long
    Dim degerler As Variant
    Dim i As Long, j As Long, temp As Variant

    ' Çalışma sayfasını belirt (Sayfa1 yerine gerçek sayfa adınızı kullanın)
    Set ws = ThisWorkbook.Worksheets("Sayfa1")

    ' A sütunundaki son dolu satırı bul
    sonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' Değerleri bir diziye aktar
    degerler = ws.Range("A1:A" & sonSatir).Value

    ' Diziyi karıştır (Fisher-Yates algoritması)
    Randomize ' Rastgele sayı üreteciyi başlat
    For i = sonSatir To 2 Step -1
        j = Int((i * Rnd) + 1)
        temp = degerler(i, 1)
        degerler(i, 1) = degerler(j, 1)
        degerler(j, 1) = temp
    Next i

    ' B sütununu temizle (önceki verileri sil)
    ws.Range("B1:B" & sonSatir).ClearContents

    ' Karıştırılmış değerleri B sütununa yaz
    ws.Range("B1").Resize(sonSatir, 1).Value = degerler

    'Belleği temizle
    Set ws = Nothing

End Sub

Hocam ilgi ve alakanız için çok teşekkür ederim.
Şu an ufak bir sıkıntı var, A sütunu 2. satırdan başlıyor, yalnız B sütununa yazarken 1. satırdan başlıyor.

 ws.Range("B2").Resize(sonSatir, 1).Value = degerler

şeklinde düzenledim, bu seferde en altta bir satır fazla yazıyor.

Çok önemli değil ama yinede yapmışken tam yapalım istedim.

iyi Akşamlar.

 

[volki_112]

Hocam ilgi ve alakanız için çok teşekkür ederim.
Şu an ufak bir sıkıntı var, A sütunu 2. satırdan başlıyor, yalnız B sütununa yazarken 1. satırdan başlıyor.

ws.Range("B2").Resize(sonSatir, 1).Value = degerler

şeklinde düzenledim, bu seferde en altta bir satır fazla yazıyor.

Çok önemli değil ama yinede yapmışken tam yapalım istedim.

iyi Akşamlar.

Yazdigim koddaki
degerler = ws.Range("A1:A" & sonSatir).Value
Bu kısmı A1 deki 1 i 2 yapın