• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Kelimedeki Harfleri Random Dizme

F

farisakboga

Katılım
26 Nisan 2019
Mesajlar
161
Excel Vers. ve Dili
Excel 2019 64 bit Tr
Ekteki dosyayı forumda buldum. A sütunundaki kelimenin harflerini B sütununa alfabetik şekilde diziyor. Alfabetik değil de karışık dizmesini sağlayabilir miyiz?
 

Ekli dosyalar

Kod: 
Sub sirala2()

Dim kelime As String, i As Integer, j As Integer, x As Variant

Dim kelimelist() As String



For Sat = 1 To [A65536].End(3).Row

    kelime = Cells(Sat, "A")

    For karistir = 1 To 20

  

    i = Int((Len(kelime) * Rnd) + 1)

    j = Int((Len(kelime) * Rnd) + 1)

 

            If Mid(kelime, i, 1) > Mid(kelime, j, 1) Then

                x = Mid(kelime, i, 1)

                Mid(kelime, i, 1) = Mid(kelime, j, 1)

                Mid(kelime, j, 1) = x

            End If

      

    Next

    Cells(Sat, "B") = kelime

Next Sat

End Sub

şeklinde yapınca rastgele oluşturdu. 20 kere karıştırsa yeter dedim. Ama kelimeleriniz uzunsa daha fazla da karıştırılabilir.
 
mrwarrior' Alıntı:
Kod: 
Sub sirala2()

Dim kelime As String, i As Integer, j As Integer, x As Variant

Dim kelimelist() As String



For Sat = 1 To [A65536].End(3).Row

    kelime = Cells(Sat, "A")

    For karistir = 1 To 20

 

    i = Int((Len(kelime) * Rnd) + 1)

    j = Int((Len(kelime) * Rnd) + 1)



            If Mid(kelime, i, 1) > Mid(kelime, j, 1) Then

                x = Mid(kelime, i, 1)

                Mid(kelime, i, 1) = Mid(kelime, j, 1)

                Mid(kelime, j, 1) = x

            End If

     

    Next

    Cells(Sat, "B") = kelime

Next Sat

End Sub

şeklinde yapınca rastgele oluşturdu. 20 kere karıştırsa yeter dedim. Ama kelimeleriniz uzunsa daha fazla da karıştırılabilir.
Genişletmek için tıkla ...

Çok teşekkür ederim.
 
Alternatif;

C++: 
Option Explicit

Sub Harfleri_Karistir()
    Dim Dizi As Object, Veri As Variant
    Dim X As Long, Say As Long, Son As Long
    Dim Sayi As Variant, Metin As String
    
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Range("B:B").Clear
    
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son < 2 Then Son = 2
    
    Veri = Range("A1:A" & Son).Value
    
    ReDim Liste(1 To Son, 1 To 1)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
10          Sayi = WorksheetFunction.RandBetween(1, Len(Veri(X, 1)))
            If Not Dizi.Exists(Sayi) Then
                Dizi.Add Sayi, Nothing
            Else
                GoTo 10
            End If
            If Dizi.Count < Len(Veri(X, 1)) Then
                GoTo 10
            Else
                For Each Sayi In Dizi.Keys
                    Metin = Metin & Mid(Veri(X, 1), Sayi, 1)
                Next
                If Metin <> Veri(X, 1) Then
                    Say = Say + 1
                    Liste(Say, 1) = Metin
                    Metin = ""
                    Dizi.RemoveAll
                Else
                    Dizi.RemoveAll
                    GoTo 10
                End If
            End If
        Else
            Say = Say + 1
        End If
    Next
    
    If Say > 0 Then
        Range("B1").Resize(Say, 1) = Liste
        MsgBox "Harf karıştırma işlemi tamamlanmıştır.", vbInformation
    Else
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If

    Set Dizi = Nothing
End Sub
 
Korhan Ayhan' Alıntı:
Alternatif;

C++: 
Option Explicit

Sub Harfleri_Karistir()
    Dim Dizi As Object, Veri As Variant
    Dim X As Long, Say As Long, Son As Long
    Dim Sayi As Variant, Metin As String
   
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    Range("B:B").Clear
   
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son < 2 Then Son = 2
   
    Veri = Range("A1:A" & Son).Value
   
    ReDim Liste(1 To Son, 1 To 1)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
10          Sayi = WorksheetFunction.RandBetween(1, Len(Veri(X, 1)))
            If Not Dizi.Exists(Sayi) Then
                Dizi.Add Sayi, Nothing
            Else
                GoTo 10
            End If
            If Dizi.Count < Len(Veri(X, 1)) Then
                GoTo 10
            Else
                For Each Sayi In Dizi.Keys
                    Metin = Metin & Mid(Veri(X, 1), Sayi, 1)
                Next
                If Metin <> Veri(X, 1) Then
                    Say = Say + 1
                    Liste(Say, 1) = Metin
                    Metin = ""
                    Dizi.RemoveAll
                Else
                    Dizi.RemoveAll
                    GoTo 10
                End If
            End If
        Else
            Say = Say + 1
        End If
    Next
   
    If Say > 0 Then
        Range("B1").Resize(Say, 1) = Liste
        MsgBox "Harf karıştırma işlemi tamamlanmıştır.", vbInformation
    Else
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If

    Set Dizi = Nothing
End Sub
Genişletmek için tıkla ...

Çok teşekkürler. İkisi de işimi gördü.
 
Korhan Ayhan' Alıntı:
Alternatif;

C++: 
Option Explicit

Sub Harfleri_Karistir()
    Dim Dizi As Object, Veri As Variant
    Dim X As Long, Say As Long, Son As Long
    Dim Sayi As Variant, Metin As String
   
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    Range("B:B").Clear
   
    Son = Cells(Rows.Count, 1).End(3).Row
    If Son < 2 Then Son = 2
   
    Veri = Range("A1:A" & Son).Value
   
    ReDim Liste(1 To Son, 1 To 1)
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
10          Sayi = WorksheetFunction.RandBetween(1, Len(Veri(X, 1)))
            If Not Dizi.Exists(Sayi) Then
                Dizi.Add Sayi, Nothing
            Else
                GoTo 10
            End If
            If Dizi.Count < Len(Veri(X, 1)) Then
                GoTo 10
            Else
                For Each Sayi In Dizi.Keys
                    Metin = Metin & Mid(Veri(X, 1), Sayi, 1)
                Next
                If Metin <> Veri(X, 1) Then
                    Say = Say + 1
                    Liste(Say, 1) = Metin
                    Metin = ""
                    Dizi.RemoveAll
                Else
                    Dizi.RemoveAll
                    GoTo 10
                End If
            End If
        Else
            Say = Say + 1
        End If
    Next
   
    If Say > 0 Then
        Range("B1").Resize(Say, 1) = Liste
        MsgBox "Harf karıştırma işlemi tamamlanmıştır.", vbInformation
    Else
        MsgBox "Uygun veri bulunamadı!", vbExclamation
    End If

    Set Dizi = Nothing
End Sub
Genişletmek için tıkla ...


Korhan Bey!

Vaktinde şöyle bir kod ile bana yardımcı olmuştunuz.

Sub yaz()
On Error GoTo 10
Dim yol As String
yol = Application.ThisWorkbook.Path
ChDir yol

adet = InputBox("Kaç farklı sayfa hazırlansın?")
kopya = InputBox("Her sayfa kaç kere yazdırılsın?")
With ActiveSheet.PageSetup
.FitToPagesWide = 1
.FitToPagesTall = 1
End With

For i = 1 To adet
Calculate
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yol & "\Toplama.pdf", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _
False
ActiveWindow.SelectedSheets.PrintOut Copies:=kopya, Collate:=True, _
IgnorePrintAreas:=False
Next
Exit Sub
10:
MsgBox "Lütfen sayısal veriler kullanınız!" & Chr(10) & Chr(10) & "İşlem tamamlanmadı"
End Sub

Şu an hata alıyorum. Veri girme penceresi açılmadan sayısal veriler giriniz diyor. Çözemedim bir türlü. Yardımcı olabilir misiniz?
 
Son sorunuzun bu konuyla bir alakası var mı?

Lütfen forum kurallarına uygun şekilde davranınız.
 
Konu başlığınız harfler random dizme fakat siz sonradan PDF ile ilgili bir kodlama paylaşıp yardım istiyorsunuz.

Sizce problem nerede?
 
Korhan Ayhan' Alıntı:
Konu başlığınız harfler random dizme fakat siz sonradan PDF ile ilgili bir kodlama paylaşıp yardım istiyorsunuz.

Sizce problem nerede?
Genişletmek için tıkla ...

Siz alternatif bir çözüm sunmuştunuz. Ben de daha önce başlık açmama rağmen son sorduğum soruya çözüm bulamamıştım forumda. Sizden çözüm gelince ve kodun sahibi siz olduğunuz için soruyu da burada sordum. Amacım kural ihlal etmek değil. Sadece çözüm bulmak. Ve yol gösterirseniz sevirim ve uygularım.
 
Üyelerimizden konu bütünlüğünü bozmamaları beklenir.

Bu sebeple farklı konularınız için ayrı başlıklar açarak takip etmeniz hem forumun arşivi bakımından hem de benzer sıkıntıyı yaşayan diğer üyelerimizin konuya erişimini kolaylaştırmak açısından önemlidir.
 
Korhan Ayhan' Alıntı:
Üyelerimizden konu bütünlüğünü bozmamaları beklenir.

Bu sebeple farklı konularınız için ayrı başlıklar açarak takip etmeniz hem forumun arşivi bakımından hem de benzer sıkıntıyı yaşayan diğer üyelerimizin konuya erişimini kolaylaştırmak açısından önemlidir.
Genişletmek için tıkla ...

Teşekkür ederim. Sorunum için yeni konu açıyorum.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst