استخراج كلمات عشوائية من حروف كلمة معينه

[منياوى]

من فضلكم

هل يمكن اذا كتبت أى كلمة عشوائية يتم تقسيم هذه الكلمة الى حروف ويعاد ترتيب هذه الحروف بطريقة عشوائية بحيث تعطينا كل الكلمات التى يمكن استخراجها من الكلمة التى تم كتابتها فى البداية

فمثلا إذا كتبت " إستقلال " فى خلية معينه اريد :

1- ان يتم تقسيم هذه الكلمة الى حروف فى عدة خلايا       إ    س     ت     ق     ل     ا    ل

2- وفى خلايا اخرى يتم ترتيب هذه الحروف بطريقة عشوائية بحيث نستخرج منها كل الكلمات التى تتكون من حروف الكلمة التى تم كتابتها فى البداية سواء كان لها معنى او لم يكن

فكلمة " استقلال " تصبح مثلا القتسال         الاتسقل     لاقتسالا          وهكذا

ولسيادتكم جزيل الشكر

[احمد عبد الناصر]

السلام عليكم

 

استاذ يوسف لي ملاحظة ان ناتج ما ذكرت لكلمة استقلال سيكون 5040 كلمة فهل هذا ما تريد ؟

 

تحياتي

[منياوى]

اولا : اشكرك من اعماق قلبى على سرعة واهتمامك بالرد

ثانيا : لو امكن . وانا لا اقصد كلمة " إستقلال " هذه الكلمة مجرد مثل . ولكن انا باقصد أى كلمة . لو أمكن ذلك

ولكم جزيل الشكر

[احمد عبد الناصر]

السلام عليكم

 

حسنا جرب المرفق 

 

الكود منقول بالكامل و لم اعدل فيه اي حرف .لكن لا اعرف صاحبه الاصلي .

 

النتيجة تعتمد علي عدد حروف الكلمة طبقا للتباديل في الرياضيات

 

ان كانت الكلمة3 حروف ستكون النتيجة 6 كلمات وان كانت 7 حروف ستكون النتيجة 5040 كلمة .

Dim CurrentRow As Long

Sub GetString()
    Dim lngMax As Long
    Dim InString As String
    If Val(Application.Version) > 11 Then
      lngMax = 9
    Else
      lngMax = 8
    End If
    InString = Cells(1, 1)
    If Len(InString) < 2 Then Exit Sub
    
    If Len(InString) > lngMax Then
        MsgBox "Too many permutations!", vbExclamation
        Exit Sub
    Else
        Range(Cells(2, 1), Cells(Rows.Count, 1)).ClearContents
        CurrentRow = 1
        Call GetPermutation("", InString)
    End If
End Sub

Sub GetPermutation(x As String, y As String)
'   The source of this algorithm is unknown
    Dim i As Integer, j As Integer
    j = Len(y)
    If j < 2 Then
        Cells(CurrentRow, 1) = x & y
        CurrentRow = CurrentRow + 1
    Else
        For i = 1 To j
            Call GetPermutation(x + Mid(y, i, 1), _
            Left(y, i - 1) + Right(y, j - i))
        Next
    End If
End Sub

 

 

تحياتي 

 

code+.rar

[عبدالله باقشير]

السلام عليكم

كود ذكي جدا...

جزاك الله خيرا اخي احمد

 

تقبل تحياتي وشكري

[منياوى]

تم تعديل أبريل 13, 2013 بواسطه jo11

[منياوى]