Kelimedeki Harfleri Random Dizme

farisakboga · 6 Mayıs 2021

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?

mrwarrior · 7 Mayıs 2021

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.

farisakboga · 7 Mayıs 2021

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.

Çok teşekkür ederim.

Korhan Ayhan · 7 Mayıs 2021

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

farisakboga · 7 Mayıs 2021

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

Çok teşekkürler. İkisi de işimi gördü.

farisakboga · 7 Mayıs 2021

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

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?

Korhan Ayhan · 7 Mayıs 2021

Son sorunuzun bu konuyla bir alakası var mı?

Lütfen forum kurallarına uygun şekilde davranınız.

farisakboga · 7 Mayıs 2021

Korhan Ayhan' Alıntı:
Son sorunuzun bu konuyla bir alakası var mı?

Lütfen forum kurallarına uygun şekilde davranınız.

Hangi kuralı çiğnediğimi bilmiyorum. Yardımcı olmanız için nasıl bir yol izlemeliyim. Ayrı bir başlık mı açmalıyım?

Korhan Ayhan · 7 Mayıs 2021

Konu başlığınız harfler random dizme fakat siz sonradan PDF ile ilgili bir kodlama paylaşıp yardım istiyorsunuz.

Sizce problem nerede?

farisakboga · 7 Mayıs 2021

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?

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.

Korhan Ayhan · 7 Mayıs 2021

Ü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.

farisakboga · 7 Mayıs 2021

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.

Teşekkür ederim. Sorunum için yeni konu açıyorum.

Kelimedeki Harfleri Random Dizme

farisakboga

Ekli dosyalar

mrwarrior

farisakboga

Korhan Ayhan

Administrator

farisakboga

farisakboga

Korhan Ayhan

Administrator

farisakboga

Korhan Ayhan

Administrator

farisakboga

Korhan Ayhan

Administrator

farisakboga