"Karıştır" butonu

[hezarpare]

ÜStadlar ekte verdiğim dosyada göreceksiniz iki tane tablo var. Soldaki tabloya ben ingilizce kelimeleri gireceğim "Karıştır" butonuna basınca sağdaki tabloya kelimeleri rastgele bir sırayla yazacak butona her basımşımda farklı şekilde karıştıracak. Kelimelerin sıralarını değiştiriken Sıra numaraları(Rank) değişmesin ve ingilizce kelimenin sağ tarafında boş olan hücre kelimeler karışıncada boş kalsın istiyorum. Bilmem derdimi anlatabildim mi?

 

[leumruk]

Merhaba,
Ekteki örneği inceleyin.

Private Sub CommandButton1_Click()
Dim varArr As Variant, varTemp As Variant
Dim random As Range
Dim x As Long, y As Long
For i = 3 To 9 Step 3
Range(Cells(2, i), Cells(48, i)).Copy
Cells(2, i + 18).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Set random = Range(Cells(2, i + 18), Cells(48, i + 18))
varArr = random.Value
Randomize
For x = 1 To UBound(varArr, 1)
    y = Int(Rnd() * UBound(varArr) + 1)
    varTemp = varArr(x, 1)
    varArr(x, 1) = varArr(y, 1)
    varArr(y, 1) = varTemp
Next x
random.Value = varArr
Next i
End Sub

 

[hezarpare]

Merhaba,
Ekteki örneği inceleyin.

Private Sub CommandButton1_Click()
Dim varArr As Variant, varTemp As Variant
Dim random As Range
Dim x As Long, y As Long
For i = 3 To 9 Step 3
Range(Cells(2, i), Cells(48, i)).Copy
Cells(2, i + 18).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Set random = Range(Cells(2, i + 18), Cells(48, i + 18))
varArr = random.Value
Randomize
For x = 1 To UBound(varArr, 1)
    y = Int(Rnd() * UBound(varArr) + 1)
    varTemp = varArr(x, 1)
    varArr(x, 1) = varArr(y, 1)
    varArr(y, 1) = varTemp
Next x
random.Value = varArr
Next i
End Sub

Üstadım sağolasın dosyayı açtım ama karıştır butonuna basınca garip garip sayılar çıktı. Kelimeleri karıştırmadı. Hani ben derdimi anlatamadım herhalde karıştır butonuna basınca soldaki kelimelri sağ tabloya rastgale yazacak.

 

[leumruk]

Sayıları denemek için yazdım. Örnek dosyanızda benim sayı eklediğim sütuna kelime yazacağınızı yazmıştınız. Örnek olarak sayıların yerine kelimeleri yazıp dener misiniz?

 

[hezarpare]

Tamam üstadım oldu ellerine sağlık. Peki bu kelimeleri yazdığım sütunun sol tarafındaki sutuna yazmak istiyorum. sağ sütunun boş kalmasını istiyorum bunu nasıl yaparız?

 

[leumruk]

Tamam üstadım oldu ellerine sağlık. Peki bu kelimeleri yazdığım sütunun sol tarafındaki sutuna yazmak istiyorum. sağ sütunun boş kalmasını istiyorum bunu nasıl yaparız?

Örnek üzerinden açıklar mısınız? İsteğinizi tam olarak anlayamadım.

 

[hezarpare]

Üstadım siyah yazılar senin yazdıkların. Kırmızılar benim istediklerim. Soldaki kırmızıları sağdaki gibi karmakarışık yazacak.

 

[leumruk]

Dosyanız ekte.

Private Sub CommandButton1_Click()
Dim varArr As Variant, varTemp As Variant
Dim random As Range
Dim x As Long, y As Long
Application.ScreenUpdating = False
[t2:u48,w2:x48,z2:aa48].ClearContents
For r = 2 To 3
For i = r To 9 Step 3
Range(Cells(2, i), Cells(48, i)).Copy
Cells(2, i + 18).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Set random = Range(Cells(2, i + 18), Cells(48, i + 18))
varArr = random.Value
Randomize
For x = 1 To UBound(varArr, 1)
    y = Int(Rnd() * UBound(varArr) + 1)
    varTemp = varArr(x, 1)
    varArr(x, 1) = varArr(y, 1)
    varArr(y, 1) = varTemp
Next x
random.Value = varArr
Next i
Next r
End Sub

 

[hezarpare]

Dosyanız ekte.

Private Sub CommandButton1_Click()
Dim varArr As Variant, varTemp As Variant
Dim random As Range
Dim x As Long, y As Long
Application.ScreenUpdating = False
[t2:u48,w2:x48,z2:aa48].ClearContents
For r = 2 To 3
For i = r To 9 Step 3
Range(Cells(2, i), Cells(48, i)).Copy
Cells(2, i + 18).PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
Set random = Range(Cells(2, i + 18), Cells(48, i + 18))
varArr = random.Value
Randomize
For x = 1 To UBound(varArr, 1)
    y = Int(Rnd() * UBound(varArr) + 1)
    varTemp = varArr(x, 1)
    varArr(x, 1) = varArr(y, 1)
    varArr(y, 1) = varTemp
Next x
random.Value = varArr
Next i
Next r
End Sub

Üstadım çok sağolasın. Teşekkürler, Allah razı olsun.

 

[leumruk]

Üstadım çok sağolasın. Teşekkürler, Allah razı olsun.

Rica ederim. İyi çalışmalar.