DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sayın hocam merhabalar. Bu dosyada bulunan soru ve cevapları 4 grup oluşturacak şekilde düzenleyebilmemiz mümkün mü ? Soru ve şıkların yeri her grupta farklı yerlerde olabilir mi ?Ekte dosyanıza gerekli kodları yazdım. Sanıyorum isteğinizi karşılayacaktır.
Her çalıştırdığınızda şıkların yeri değişecektir.Sayın hocam merhabalar. Bu dosyada bulunan soru ve cevapları 4 grup oluşturacak şekilde düzenleyebilmemiz mümkün mü ? Soru ve şıkların yeri her grupta farklı yerlerde olabilir mi ?
Sub test()
Dim i%, ii%, rng As Range, tmp$, sut, s1 As Byte, s2 As Byte
sut = Array(4, 6, 8, 10)
For i = 3 To 52
For ii = 1 To 10
basla:
s1 = WorksheetFunction.RandBetween(0, 3)
s2 = WorksheetFunction.RandBetween(0, 3)
If s1 = s2 Then GoTo basla
tmp = Cells(i, sut(s1)).Value
Cells(i, sut(s1)).Value = Cells(i, sut(s2)).Value
Cells(i, sut(s2)).Value = tmp
Next ii
Next i
End Sub
Dosyanız ektedir.Sayın hocam merhabalar. Bu dosyada bulunan soru ve cevapları 4 grup oluşturacak şekilde düzenleyebilmemiz mümkün mü ? Soru ve şıkların yeri her grupta farklı yerlerde olabilir mi ?
Sub test()
Application.ScreenUpdating = False
Dim i%, ii%, rng As Range, tmp, sut, s1 As Byte, s2 As Byte
sut = Array(4, 6, 8, 10)
For i = 3 To 52
For ii = 1 To 10
basla:
s1 = WorksheetFunction.RandBetween(0, 3)
s2 = WorksheetFunction.RandBetween(0, 3)
If s1 = s2 Then GoTo basla
tmp = Cells(i, sut(s1)).Value
Cells(i, sut(s1)).Value = Cells(i, sut(s2)).Value
Cells(i, sut(s2)).Value = tmp
Next ii
Next i
For i = 1 To 200
basla2:
s1 = WorksheetFunction.RandBetween(3, 52)
s2 = WorksheetFunction.RandBetween(3, 52)
If s1 = s2 Then GoTo basla2
tmp = Cells(s1, 2).Resize(, 9).Value
Cells(s1, 2).Resize(, 9).Value = Cells(s2, 2).Resize(, 9).Value
Cells(s2, 2).Resize(, 9).Value = tmp
Next i
Application.ScreenUpdating = True
End Sub
Dosyanız ektedir.