Word Dosyasında Kelimeleri karıştırmak

[dogusvealp]

KADRAJ
KADRAN
KADRAT
KADRİL
.
.
.
STATİK
STATOR
STEPNE
STERİL
STEROL

Şeklinde alfabetik sırayla devam eden bine yakın kelime var ve ben bunların sırasını karıştırmak istiyorum.Mesela Statatik, Kadran, Stator, Kadril vs... gibi.
Böyle bir şey yapmam mümkün mü acaba?

 

[netcini]

Şöyle yapabilirsiniz.

Kelimeleri excelde A sütünuna yapıştırın.

B sütünuna =RASTGELEARADA(1;2000) formülünü yazın
Kelimelerin bitişine kadar, bu formülü aşağıya doğru kopyalayın.

Sonra B sütunu komple seçip kopyalayın. Ve değerleri yapıştırın.

A ve B sütünunu seçerek B sütünuna göre sıralama yapın. Kelimeleriniz karışmış olacak.

A sütünündaki kelimeleri seçip kopyalaıp, Word'a metin yapıştır ile yapıştırırsınız.

 

[Asri]

Alternatif makrolu çözüm;

Kelimelerin A kolonunda bulunduğu varsayılmıştır.
B kolonu geçici kullanım için silinecektir.
Kelime sayısı değişken olabilir.

Sub karistir()
   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   
   'Sıralama için sayı üret
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   ustsayi = sonsatir
   altsayi = 1
   Range("B1:B" & sonsatir).Clear
   For i = 1 To sonsatir
   
basla:
     DoEvents
     Randomize
     sayi = Int((ustsayi - altsayi + 1) * Rnd + altsayi)
     If WorksheetFunction.CountIf(Range("B1:B" & sonsatir), sayi) > 0 Then
        GoTo basla
     End If
     If sayi = altsayi Then altsayi = sayi + 1
     If sayi = ustsayi Then ustsayi = sayi - 1
     
     Cells(i, "B").Value = sayi
   Next i
   
  'Yeni sıralamayı yap
    sayfaadi = ActiveSheet.Name
    Columns("A:B").Select
    Range("B1").Activate
    ActiveWorkbook.Worksheets(sayfaadi).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(sayfaadi).Sort.SortFields.Add Key:=Range("B1:B" & sonsatir _
        ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(sayfaadi).Sort
        .SetRange Range("A1:B" & sonsatir)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Columns("B:B").Select
    Selection.ClearContents
    Range("B1").Select
    
   Application.ScreenUpdating = True
   Application.DisplayAlerts = True
   MsgBox ("Karıştırma işlemi tamamlandı.")
End Sub

 

[dogusvealp]

Çok teşekkür ederim netcini ve asri hocalarım sayenizde sorunumu hallettim. İyi günler ve iyi çalışmalar dilerim sizlere.