Satirlar

[Yakut]

slm

bu konu ile ilgili konulari aradim , ama bulamadim

soru :

A B C D E F

isim Soyisim x y t m


böyle bir liste varsayalim asagi dogr 50 ye kadar gidiyor.

bunlari satir olarak rastgele karistirabilirmiyiz Satirlari tabii bilgiler degismeyecek.

 

[Ferhat Pazarçevirdi]

Aşağıdaki gibi bir kod kullanılabilir. Sorunuzu bir çok yolla çözmek mümkün aslında... Ben bir Recordset nesnesinde, Cursor'ı rastgele harekete ettirerek sonuç aldım. Ama siz, bir dizi değişkene veya bir kolleksiyona da bu işleri yaptırabilirsiniz. Veyahut, formüller vasıtası ile yapılabilir.

Çalışan kodlar aşağıdaki gibidir.

NOT : Eğer kodları kopyalama usulu çalıştıracaksanız; öncelikle; Microsoft Activex Data Object Recordset X.X Library'nin referanslara ilave edilmesi gerekmekte.

Sub Karistir()
    Dim rs As ADOR.Recordset
    Dim i As Integer
    Dim j As Integer
    Dim istr As Integer
    Dim iRsStr As Integer
    Dim rng As Range
    Dim rngHcr As Range
    
    Set rs = New ADOR.Recordset
    
    With rs
        With .Fields
            For i = 1 To 6: .Append "Sutun" & i, adChar, 250: Next i
        End With
        
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        
        .Open
    
        Set rng = Range("A1:F" & ActiveSheet.UsedRange.Rows.Count)
        
        For Each rngHcr In rng.Cells
            If j = 6 Then j = 0
            
            If j = 0 Then
                .AddNew
            End If
            
            .Fields(j).Value = CStr(rngHcr)
            
            j = j + 1
        Next
    
        .MoveFirst
        
        Do Until .RecordCount = 0
            
            Randomize
            iRsStr = CInt(.RecordCount * Rnd())
            
            If iRsStr = .RecordCount Then iRsStr = iRsStr - 1
            
            .Move (iRsStr)
            
            istr = istr + 1
            
            For j = 0 To 5
                Cells(istr, j + 8) = Trim(.Fields(j).Value)
            Next
           
           .Delete adAffectCurrent
           .MoveFirst
        Loop
        
        .Close
    
    End With
    
    Set rs = Nothing
    Set rng = Nothing
End Sub

 

[Yakut]

slm

cevapiniza tesekkürler ama benim demek istedigim, bir örnek dosya ekliyorum,
burada sorularin yerleri degisicek sekilde olmasini istiyorum. yani 2. sutundaki soru herhangi baska satira gelecek .her soru yerleri siralamasi degisik olacak sekilde .

saygilar

 

[Ferhat Pazarçevirdi]

Ben ne demek istdeiğinizi anlamadım. size gönderdiğim örnete, A-F sütunlarında bulunan verilerin hepsi, aynen H-M sütunları arasına çekiliyor. Tabi karıştırılarak ...

Eğer siz, bu karışımın aynı liste üzerinde olmasını istiyorsanız, aşağıdaki bölümde kırmızı ile gösterilen yerdeki 8'i, 1 yapın, deneyin.

....
            For j = 0 To 5
                Cells(istr, j + 1) = Trim(.Fields(j).Value)
            Next
....

 

[Yakut]

cok güzel calisiyor, tesekkürler ama birinci sütün degismesini istemiyorum. 1. Sütün baslik olarak kalmasi icin.

 

[Ferhat Pazarçevirdi]

O zamanda, yukarıda revize ettiğimiz dögüyü şu şekilde bir kez daha revize ediniz.

            For j = [COLOR=red][B]1[/B][/COLOR] To 5
                Cells(istr, j + 1) = Trim(.Fields(j).Value)
            Next

 

[Yakut]

degisik bir metodla buldum, fakat baska sayfalardan bu kodu calistiramiyorum.Kitabin acilisinda kod calisiyor.