ListBox'ta ki verileri hücrelere random yerleştirmek

[CengizYurek]

Beni aşan bir durumla karşı karşıya kaldım.
Listbox1'de bulunan listeyi A1: D5 e kadar her bir veriyi en az 2 alt satıra denk gelecek şekilde random yerleştirmek istiyorum acaba mümkün mü ?

Örnek :
Listbox'da ki veri : Ürün 1, Ürün 2, Ürün 3, Ürün 4, Ürün 5, Ürün 6, Ürün 7, ürün 8, ürün 9
Butona basınca aşağıdaki gibi bir tablo oluşmalı

Ürün 3	ürün 5	ürün 1	ürün 6
ürün 4	ürün 7	ürün 2	ürün 9
ürün 5	ürün 8	ürün 1	ürün 3
ürün 6	ürün 2	ürün 4	ürün 7
ürün 1	ürün 3	ürün 5	ürün 9

 

[ÖmerBey]

Merhaba,
Deneyiniz...

Dim a As Integer
Dim b As Byte, s As Byte
Dim x As String
Dim dz As Variant

dz = ListBox1.List
With Range("A1:D5")
For a = .Cells.Count To 1 Step -1
    For b = LBound(dz) To UBound(dz)
        s = Int(Rnd() * (UBound(dz) + 1))
        x = dz(b, 0)
        dz(b, 0) = dz(s, 0)
        dz(s, 0) = x
    Next
   
    For b = LBound(dz) To UBound(dz)
        If WorksheetFunction.CountIf(Range("A" & .Cells(a).Row & ":D" & .Cells(a).Row + 1), dz(b, 0)) = 0 Then
            .Cells(a).Value = dz(b, 0)
            Exit For
        End If
    Next
Next
End With

 

[CengizYurek]

Merhaba,
Deneyiniz...

Dim a As Integer
Dim b As Byte, s As Byte
Dim x As String
Dim dz As Variant

dz = ListBox1.List
With Range("A1:D5")
For a = .Cells.Count To 1 Step -1
    For b = LBound(dz) To UBound(dz)
        s = Int(Rnd() * (UBound(dz) + 1))
        x = dz(b, 0)
        dz(b, 0) = dz(s, 0)
        dz(s, 0) = x
    Next
  
    For b = LBound(dz) To UBound(dz)
        If WorksheetFunction.CountIf(Range("A" & .Cells(a).Row & ":D" & .Cells(a).Row + 1), dz(b, 0)) = 0 Then
            .Cells(a).Value = dz(b, 0)
            Exit For
        End If
    Next
Next
End With

Çok güzel çalıştı emeğinize elinize sağlık. Peki hepsini eşit veya eşite yakın yerleştirme imkanımız var mı ? 4 ürün 6 kere , 5 ürün 5 kere gibi mesela.

 

[ÖmerBey]

Mevcut şartlarda aşağıdaki kodlar işinizi görecektir muhtemelen. Ancak şartlar değiştiğinde hata oluşması muhtemeldir.
Deneyiniz...

Dim a As Integer
Dim b As Byte, s As Byte, x1 As Byte
Dim x As String
Dim dz As Variant

ReDim dz(ListBox1.ListCount - 1, 1)

For b = LBound(dz) To UBound(dz)
    dz(b, 0) = ListBox1.List(b, 0)
    dz(b, 1) = 0
Next

With Range("A1:D5")
.ClearContents
Randomize
For a = .Cells.Count To 1 Step -1
    For b = LBound(dz) To UBound(dz)
        s = Int(Rnd() * (UBound(dz) + 1))
        x = dz(b, 0)
        x1 = dz(b, 1)
        dz(b, 0) = dz(s, 0)
        dz(b, 1) = dz(s, 1)
        dz(s, 0) = x
        dz(s, 1) = x1
    Next
    For b = LBound(dz) To UBound(dz)
        If WorksheetFunction.CountIf(Range("A" & .Cells(a).Row & ":D" & .Cells(a).Row + 1), dz(b, 0)) = 0 And dz(b, 1) = Application.Min(dz) Then
            .Cells(a).Value = dz(b, 0)
            dz(b, 1) = dz(b, 1) + 1
            Exit For
        End If
    Next
Next
End With

 

[CengizYurek]

Mevcut şartlarda aşağıdaki kodlar işinizi görecektir muhtemelen. Ancak şartlar değiştiğinde hata oluşması muhtemeldir.
Deneyiniz...

Dim a As Integer
Dim b As Byte, s As Byte, x1 As Byte
Dim x As String
Dim dz As Variant

ReDim dz(ListBox1.ListCount - 1, 1)

For b = LBound(dz) To UBound(dz)
    dz(b, 0) = ListBox1.List(b, 0)
    dz(b, 1) = 0
Next

With Range("A1:D5")
.ClearContents
Randomize
For a = .Cells.Count To 1 Step -1
    For b = LBound(dz) To UBound(dz)
        s = Int(Rnd() * (UBound(dz) + 1))
        x = dz(b, 0)
        x1 = dz(b, 1)
        dz(b, 0) = dz(s, 0)
        dz(b, 1) = dz(s, 1)
        dz(s, 0) = x
        dz(s, 1) = x1
    Next
    For b = LBound(dz) To UBound(dz)
        If WorksheetFunction.CountIf(Range("A" & .Cells(a).Row & ":D" & .Cells(a).Row + 1), dz(b, 0)) = 0 And dz(b, 1) = Application.Min(dz) Then
            .Cells(a).Value = dz(b, 0)
            dz(b, 1) = dz(b, 1) + 1
            Exit For
        End If
    Next
Next
End With

Gayet güzel çalışııyor elinize sağlık. Kodun üstüne adınızı yazacağım.

 

[ÖmerBey]

Rica ederim,
Adımı yazma konusunda nasıl karar alacağınızı size bırakmakla birlikte şunu da belirtmek istiyorum: İsimsiz olarak paylaştığım tüm kodları ticari veya şahsi her projenizde isimsiz olarak kullanabilirsiniz. Bundan doğacak bir hakkım varsa helaldir.
İyi çalışmalar...