Makroda rasgele sıralama

[mtrcbedir]

Arkadaşlar merhaba,

Sizlerin tecrübesi ve yardımına ihtiyaç duymaktayım. Yardımcı olursanız çok sevinirim.

Bu işlemi makroda yapmam gerekiyor*

B sütununda Mavi Mavi Mavi Kırmızı Kırmızı Sarı Sarı Sarı Sarı şeklinde aşağıya doğru giden renklerim var. Bu renkleri c sütununda rasgele karıştırmak istiyorum.

Örnek olarak B Sütunu bu şekilde görünüyor
Mavi
Mavi
Mavi
Kırmızı
Kırmızı
Sarı
Sarı
Sarı

İşkle sonrası olması gereken C sütunu bu şekilde rasgele sıralanmış olmalı
Kırmızı
Sarı
Sarı
Mavi
Kırmızı
Mavi
Mavi
Kırmızı
Mavi
Sarı

 

[ÖmerBey]

Merhaba,
Deneyiniz...

Sub kod()
s = Cells(Rows.Count, "B").End(3).Row
dz = Range("B1:B" & s).Value
For a = LBound(dz) To UBound(dz)
    Randomize
    b = Int(Rnd * UBound(dz)) + 1
    x = dz(a, 1)
    dz(a, 1) = dz(b, 1)
    dz(b, 1) = x
Next
Range("C1:C" & s).Value = dz
End Sub

 

[mtrcbedir]

Hocam maalesef çalışmadı. daha doğrusu bir tane yazdırıyor sonra 5 satır boş bir tane daha yazdırıyor sonra gene aynı . arada #YOK yazıyor.
Yapabileceğimiz bir işlem var mıdır başka

 

[ÖmerBey]

Örnek bir dosya paylaşırsanız dosya üzerinde çalışalım.
Dosyanızı paylaşım sitelerine yükleyip link vererek paylaşabilirsiniz.

 

[mtrcbedir]

Örnek bir dosya paylaşırsanız dosya üzerinde çalışalım.
Dosyanızı paylaşım sitelerine yükleyip link vererek paylaşabilirsiniz.

Hocam çok teşekkür ederim. Çok amatör yapıyorum zaten, desteğiniz çok iyi olacak,

Sizin yolladığınız kodlar makronun en alt kısmında,

123.xlsx

1 file sent via WeTransfer, the simplest way to send your files around the world

wetransfer.com

 

[mtrcbedir]

Hocam çok teşekkür ederim. Çok amatör yapıyorum zaten, desteğiniz çok iyi olacak,

Sizin yolladığınız kodlar makronun en alt kısmında,

123.xlsx

1 file sent via WeTransfer, the simplest way to send your files around the world

wetransfer.com

B sütünunda sırayla yazılan renkler c sütununa karışık şekilde yazılması gerekiyor.

 

[ÖmerBey]

Paylaştığınız dosyanın B sütunu tamamen boş.
Dilerseniz dosyanızı yeniden yükleyin. Dilerseniz de yukarıda paylaştığım kodun boş dosyaya uygulanmış halini şuradan indirip incelebilirsiniz.

 

[mtrcbedir]

Paylaştığınız dosyanın B sütunu tamamen boş.
Dilerseniz dosyanızı yeniden yükleyin. Dilerseniz de yukarıda paylaştığım kodun boş dosyaya uygulanmış halini şuradan indirip incelebilirsiniz.

Hocam, Makroyu kaydetmemişim.
Bu şekilde iletmiş olayım
https://wetransfer.com/downloads/4d938d1e39c76ce840f325f529f04cd120211218194722/ad45741fec61f0d68d800bfd9991f6de20211218194736/d81bca

 

[ÖmerBey]

Dosyanız bu şekildeyse paylaştığım kodun ilk satır haricinde doğru çalışması gerekiyordu.
Acaba dosyanızda B sütununda formüller olabilir mi?
Bir de emin olmak için soruyorum değerler C2 hücresinden aşağı doğru yazılacak değil mi?

 

[mtrcbedir]

Dosyanız bu şekildeyse paylaştığım kodun ilk satır haricinde doğru çalışması gerekiyordu.
Acaba dosyanızda B sütununda formüller olabilir mi?
Bir de emin olmak için soruyorum değerler C2 hücresinden aşağı doğru yazılacak değil mi?

Herhangi bir formül bulunmuyor, evet doğru hocam C2 hücresinden başlıyor.

 

[ÖmerBey]

Aşağıdaki kodları deneyiniz...

Sub kod()
Dim a As Long, b As Long
Dim x As String
ReDim dz(0)
For a = 2 To Cells(Rows.Count, "B").End(3).Row
    If Cells(a, "B") <> "" Then
        ReDim Preserve dz(b)
        dz(b) = Cells(a, "B")
        b = b + 1
    End If
Next
For a = LBound(dz) To UBound(dz)
    Randomize
    b = Int(Rnd * UBound(dz))
    x = dz(a)
    dz(a) = dz(b)
    dz(b) = x
Next
Range("C2").Resize(UBound(dz) + 1).Value = Application.Transpose(dz)
End Sub

 

[mtrcbedir]

If Cells(a, "B") <> "" Then
bu satırda hata veriyor.

 

[ÖmerBey]

Sebebini bilemeyeceğim, bende hata vermiyor.
Dosyanız şurada : LİNK

 

[mtrcbedir]

Sebebini bilemeyeceğim, bende hata vermiyor.
Dosyanız şurada : LİNK

İnceleme fırsatınız olabilir mi tekrardan dosyayı topladım.
Değişken değerleri yerine sayı yazabilirsiniz.


https://wetransfer.com/downloads/6fd7c03ec96dad175261e0465557f6d120211218211921/302c9e4ff165134c28f556dee4dce82720211218211934/80d303

 

[ÖmerBey]

If Cells(a, "B") <> "" Then
bu satırda hata veriyor.

Bu satırı aşağıdaki şekilde değiştirip deneyiniz.
If Not IsError(Cells(a, "B")) And Not IsEmpty(Cells(a, "B")) Then