Satır ve sütundaki sayıları rastgele karıştırma

[BedriA]

Alternatif;

C kolonunu yardımcı olarak kullanıp temizler.

Sub karistir()
   Application.ScreenUpdating = False
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   ustsayi = sonsatir: altsayi = 1
   Range("C1:C" & sonsatir).Clear
   For i = 2 To sonsatir
basla:
     DoEvents: Randomize
     sayi = Int((ustsayi - altsayi + 1) * Rnd + altsayi)
     If WorksheetFunction.CountIf(Range("C1:C" & sonsatir), sayi) > 0 Then GoTo basla
     If sayi = altsayi Then altsayi = sayi + 1
     If sayi = ustsayi Then ustsayi = sayi - 1
     Cells(i, "C").Value = sayi
   Next i
   Range("A:C").Sort Key1:=Cells(1, "C"), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
   Columns("C:C").ClearContents
   Range("B1").Select
   Application.ScreenUpdating = True
   MsgBox ("Karıştırma işlemi tamamlandı.")
End Sub

Asri Hocam,

Bu kod sanki 1 satıra karışmıyor.
2. satırdan itibaren karıştırma yapıyor.

Ben de bu kodu arıyordum.

 

[Asri]

Asri Hocam,

Bu kod sanki 1 satıra karışmıyor.
2. satırdan itibaren karıştırma yapıyor.

Ben de bu kodu arıyordum.

Evet 2. satırdan sonra karıştırma yapar.

 

[BedriA]

Evet 2. satırdan sonra karıştırma yapar.

Teşekkür ederim.

 

[halit3]

Halit Hocam,

Aşağıdaki kodu A2 den başlayacak şekilde nasıl değiştirebiliriz.
A1 satırında başlık var, o satırı da değiştiriyor.

Bu kod yardımcı sutun olmadan karıştırma işlemini yapıyor.
Ve boş hücreleri dikkate alır yani boş hücrelerde herhangibir işlem yapmaz.
33 mesajdaki soruya cevaben yazıldı
kod:

Sub sorucevapdegistir()

Dim i As Long, sayi As Long, say As Long, sut As Long, son As Long, t As Long, j As Long
Sayfa = "sepet"

sut = 1
sayi = Worksheets(Sayfa).Cells(Rows.Count, sut).End(3).Row

son = sayi
If sayi > son Then sayi = son

ReDim deg1(son)
ReDim deg2(son)
ReDim deg3(son)

For j = [COLOR="red"]2[/COLOR] To sayi
If Worksheets(Sayfa).Cells(j, sut).Value <> "" Then
deg1(j) = 0
Else
deg1(j) = 1
End If
Next j
[COLOR="red"]deg1(1) = 1[/COLOR]

For i = [COLOR="red"]2[/COLOR] To sayi
If Worksheets(Sayfa).Cells(i, sut).Value <> "" Then
atla:
say = Int((Rnd * son) + 1)

If Val(deg1(say)) = 0 Then
deg2(i) = Worksheets(Sayfa).Cells(say, sut).Value
deg3(i) = Worksheets(Sayfa).Cells(say, sut + 1).Value
deg1(say) = 1
Else
GoTo atla
End If
End If
Next i

For t = [COLOR="Red"]2 [/COLOR]To sayi
If Worksheets(Sayfa).Cells(t, sut).Value <> "" Then
Sheets(Sayfa).Cells(t, sut).Value = deg2(t)
Sheets(Sayfa).Cells(t, sut + 1).Value = deg3(t)
End If
Next t

End Sub

 

[halit3]

Bu kodda istediğin satırdan başlamak için revize edildi

Sub sorucevapdegistir()

Dim i As Long, sayi As Long, say As Long, sut As Long, son As Long, t As Long, j As Long
sayfa = ActiveSheet.Name

[COLOR="Red"]bas_satir = 2[/COLOR]
sut = 1
sayi = Worksheets(sayfa).Cells(Rows.Count, sut).End(3).Row

son = sayi
If sayi > son Then sayi = son

ReDim deg1(son)
ReDim deg2(son)
ReDim deg3(son)

For j = 1 To sayi
If [COLOR="Red"]j >= bas_satir And[/COLOR] Worksheets(sayfa).Cells(j, sut).Value <> "" Then
deg1(j) = 0

Else
deg1(j) = 1
End If
Next j


For i = [COLOR="red"]bas_satir[/COLOR] To sayi
If Worksheets(sayfa).Cells(i, sut).Value <> "" Then
atla:
say = Int((Rnd * son) + 1)

If Val(deg1(say)) = 0 Then
deg2(i) = Worksheets(sayfa).Cells(say, sut).Value
deg3(i) = Worksheets(sayfa).Cells(say, sut + 1).Value
deg1(say) = 1
Else
GoTo atla
End If
End If
Next i

For t = [COLOR="red"]bas_satir[/COLOR] To sayi
If Worksheets(sayfa).Cells(t, sut).Value <> "" Then
Sheets(sayfa).Cells(t, sut).Value = deg2(t)
Sheets(sayfa).Cells(t, sut + 1).Value = deg3(t)
End If
Next t


End Sub

 

[BedriA]

Bu kodda istediğin satırdan başlamak için revize edildi

Sub sorucevapdegistir()

Dim i As Long, sayi As Long, say As Long, sut As Long, son As Long, t As Long, j As Long
sayfa = ActiveSheet.Name

[COLOR="Red"]bas_satir = 2[/COLOR]
sut = 1
sayi = Worksheets(sayfa).Cells(Rows.Count, sut).End(3).Row

son = sayi
If sayi > son Then sayi = son

ReDim deg1(son)
ReDim deg2(son)
ReDim deg3(son)

For j = 1 To sayi
If [COLOR="Red"]j >= bas_satir And[/COLOR] Worksheets(sayfa).Cells(j, sut).Value <> "" Then
deg1(j) = 0

Else
deg1(j) = 1
End If
Next j


For i = [COLOR="red"]bas_satir[/COLOR] To sayi
If Worksheets(sayfa).Cells(i, sut).Value <> "" Then
atla:
say = Int((Rnd * son) + 1)

If Val(deg1(say)) = 0 Then
deg2(i) = Worksheets(sayfa).Cells(say, sut).Value
deg3(i) = Worksheets(sayfa).Cells(say, sut + 1).Value
deg1(say) = 1
Else
GoTo atla
End If
End If
Next i

For t = [COLOR="red"]bas_satir[/COLOR] To sayi
If Worksheets(sayfa).Cells(t, sut).Value <> "" Then
Sheets(sayfa).Cells(t, sut).Value = deg2(t)
Sheets(sayfa).Cells(t, sut + 1).Value = deg3(t)
End If
Next t


End Sub

Çok teşekkür ederim Halit Hocam.