مساعدة سهلة في هذا الكود - من فضلكم

[moh.elmadany]

هذا الكود يمكنني من عمل توزيع عشوائي لاسماء المدرسين وتكون نتيجة التوزيع في عمود

t

 

  كيف اجعل النتيجة تظهر في عمد اخر مثلا
w

وتكون البيانات الناتجة مختلفة عما هي في العمود الاول
=========================================
Sub randomCollection()
    Dim Names As New Collection
    Dim lastRow As Long, i As Long, j As Long, lin As Long
    Dim wk As Worksheet
 
    Set wk = Sheets("البيانات الأساسية")
 
    With wk
        lastRow = .Cells(.Rows.Count, "b").End(xlUp).Row
    End With
 
    For i = 2 To lastRow
        Names.Add wk.Cells(i, 1).Value
    Next i
 
    lin = 1
    For i = lastRow - 1 To 1 Step -1
        j = Application.WorksheetFunction.RandBetween(1, i)
        lin = lin + 1
        Range("t" & lin) = Names(j)
        Names.Remove j
    Next i
 
End Sub

[Ali Mohamed Ali]

قم بتغيير هذا السطر من الكود

Range("t" & lin) = Names(j)

الى

 Range("w" & lin) = Names(j)

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

 

[سليم حاصبيا]

جرب هذا الملف

الماكرو

Option Explicit
Sub Rand_Names()
If ActiveSheet.Name <> "Salim" Then Exit Sub
Dim i%, k%, Final_Row%
Final_Row = Cells(Rows.Count, 1).End(3).Row
 With CreateObject("System.Collections.SortedList")
       For i = 2 To Final_Row
        .Item(Rnd) = Range("a" & i)
       Next i
   For i = 0 To .Count - 1
      Cells(k + 2, 3) = .GetByIndex(i)
       k = k + 1
   Next i
 End With

End Sub

الملف مرفق

 

Random_list.xlsm

[moh.elmadany]

حضرتك في ملفك المرفق اتعمل التوزيع على عمود الـ
c
فقط

انا عايز يتعمل توزيع عشوائي تاني مثلا في عمود 
d
و
f

 

 ويكون التوزيع العشوائي في كل عمود مختلف عن باقي الاعمدة

2 hours ago, ali mohamed ali said:

قم بتغيير هذا السطر من الكود

Range("t" & lin) = Names(j)

الى

 Range("w" & lin) = Names(j)

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

 

حضرتك انا مش عايز اكرره 
انا عايز يتعمل ترتيب عشوائي مختلف عن العمود الاول

[سليم حاصبيا]

تم معالجة الامر

الكود

Option Explicit
Sub Rand_Names()
If ActiveSheet.Name <> "Salim" Then Exit Sub
Dim i%, k%, Final_Row%
Dim x As Long
x = Cells(2, Columns.Count).End(1).Column + 1
If x < 4 Then x = 4
Final_Row = Cells(Rows.Count, 3).End(3).Row
 With CreateObject("System.Collections.SortedList")
       For i = 2 To Final_Row
        .Item(Rnd) = Range("c" & i)
       Next i
   For i = 0 To .Count - 1
      Cells(k + 2, x) = .GetByIndex(i)
       k = k + 1
   Next i
 End With

End Sub

الملف

 

Random_list 2.xlsm

[moh.elmadany]

انت رجل عظيم بجد ربنا يبارك فيك ويحفظك

معلش يا فندم .. هل ممكن نتخطى الفراغات .. يعني لو فيه فراغ في عمود المصدر .. ممكن الفراغ ده يتخطاه؟ وميتكررش حد في نفس العمود ؟ يعني اكيد العمود هيبقى ناقص من تحت مثلا؟
هل ده ممكن ؟

ثانيا .. هل ممكن ميبقاش فيه تكرار في نفس الصف الا بعد ما الاسماء كلها تنضاف لنفس الصف؟ فبعد كدا يتكرر ؟

[سليم حاصبيا]

لك ما تريد

 

 

Random_list 3.xlsm

[Ali Mohamed Ali]

بارك الله فيك أستاذ سليم أكواد رائعة وممتازة وادت المطلوب يكل دقة

زادك الله من علمه وغفر لك وجعله فى ميزان حسناتك جزاك الله كل خير

[moh.elmadany]

بارك الله فيك استاذي - الحمد لله مشكلة تخطى الفراغات تم حلها ..

---------------------
(1)
معلش يا فندم مازالت مشكلة تكرار نفس الاسم في نفس الصف
هل ممكن يتكرر الاسم في نفس الصف .. لكن بعد استنفاذ كل الاسماء في نفس الصف؟
---------------------

(2)
مع الضغط على الزرار .. الملف بينزل تحت .. هل ممكن حلها؟
---------------------
(3) واخر نقطة:
ايضا ازاى اغير عمود المصدر بدلا من الـ
C
اخليه 
F

وعمود النتائج يبدأ من 
U

------------------------------

واشكر لك سعة صدرك

////رد

لا تنس اننا نتعامل مع اعداد عشوائية لذلك يمكن ان يتكرر اي صف (وليس الصف الاول فقط) لكن هذا يحدث يما نسبته 0.5 %

اذا صادف وحدث ذلك يمكن حذف العامود بكامله و اعادة تشغيل الماكرو

لعدم تنزيل الملف الى اسفل امسح هذه العبارة من الكود

 

Range("c" & i).Select

[سليم حاصبيا]

1 دقيقه مضت, ali mohamed ali said:

بارك الله فيك أستاذ سليم أكواد رائعة وممتازة وادت المطلوب يكل دقة

زادك الله من علمه وغفر لك وجعله فى ميزان حسناتك جزاك الله كل خير

يرجى حذف هذه الجملة من الكود (وقعت سهواُ)

Range("c" & i).Select

لانها تشكل عيئاً على الكود بالاضافة الى انها تجعل رأس الجداول غير مرئية بعد تنفيذه 

 

[moh.elmadany]

تمام معالي الاستاذ سليم
أخر نقطة معلش حضرتك لم تجاوبني عليها 

ايضا ازاى اغير عمود المصدر بدلا من الـ
C
اخليه 
F

وعمود النتائج يبدأ من 
U

[سليم حاصبيا]

الصفحة Officena من هذا الملف

 

Random_list 4.xlsm

[moh.elmadany]

تسلم إيدك أستاذنا

هل ممكن حضرتك جعل النتائج على 30 عمود بضغطة زرار واحدة

بدلا من الضغط ثلاثين مرة؟

[سليم حاصبيا]

ممكن أوي

 

Random_list 5.xlsm

[moh.elmadany]

معلش يا فندم ارجوك - كمل جميلك معايا في الملف ده
المطلوب في المرفق

وشكرا لذوق حضرتك

 

Random_list 5(تم الاسترداد تلقائياً).xlsm

تم تعديل أبريل 12, 2018 بواسطه moh.elmadany

[سليم حاصبيا]

جرب هذا الملف صفحة salim

Random_list 6.xlsm

[moh.elmadany]

شكرا لحضرتك وبارك الله فيك 
تم انجاز فوق الـ 90% حضرتك ..

هل ممكن الفكرة المشار اليها في المرفق تكون محل تنفيذ؟

Random_list 6 (1).xlsm

[سليم حاصبيا]

على اساس انها مساعدة سهلة في هذا الكود

جرب هذا الملف الصفحة salim_two

 

Random_list 7.xlsm

[moh.elmadany]

تقبل اعتذاري إن كان فيه مشقة سببتها لحضرتك
مكنش مقصود اكتب العنوان ده - لكن أكيد حضرتك عارف أن الفكرة في بدايتها بتكون صغيرة - لكنها بتطور بعد ذلك - وده سبب كثرة التعديلات اللي طلبتها بعد كدا لحضرتك
العمل قارب على الانتهاء بفضل الله ثم بمجهودات حضرتك 

 

أنا لازم أشكر حضرتك على صنيعك معايا 
وخدمتك الغالية علينا - اللي من شأنها تطوير العمل الإداري داخل مؤسسة الأزهر الشريف
وأخيرا : استمسح حضرتك:

 النظر في الملف المرفق لعله يكون أخر طلب ان شاء الله

test.xlsm

تم تعديل أبريل 14, 2018 بواسطه moh.elmadany

[سليم حاصبيا]

ممكن هذا الماكرو يحل المشكلة

Option Explicit
Sub eliminat_dup()
Dim xRg1, xRg2 As Range
Dim k1%, k2%, i%, j%
Dim Temp, m%, xx%: xx = 1
Dim c%, t%: t = [a11]
c = Cells(1, Columns.Count).End(1).Column
If c < 21 Then Exit Sub
Set xRg1 = Cells(1, 21).CurrentRegion
Set xRg2 = Cells(1, 21 + t + 1).CurrentRegion
k1 = xRg1.Rows.Count: k2 = xRg2.Rows.Count

'===============================
 For i = 2 To k1
    For j = 1 To t - 1
    If xx >= k1 Then xx = 1

    m = Application.CountIf(xRg1.Rows(i), xRg1.Cells(i, j))
    If m > 1 Then
       Temp = xRg1.Cells(i, j)
        If (i + xx) < k1 \ 2 Then
         xRg1.Cells(i, j) = xRg1.Cells(i + xx, j)
       Else
       xx = 1
        xRg1.Cells(i, j) = xRg1.Cells(i + xx, j)
        End If
         xRg1.Cells(i + xx, j) = Temp
          xx = xx + 1
     End If
    Next
    Next
xx = 1
'==========================
For i = 2 To k2
    For j = 1 To t - 1
    If xx >= k2 Then xx = 1
    m = Application.CountIf(xRg2.Rows(i), xRg2.Cells(i, j))
    If m > 1 Then
       Temp = xRg2.Cells(i, j)
        If (i + xx) < k2 \ 2 Then
         xRg1.Cells(i, j) = xRg2.Cells(i + xx, j)
       Else
       xx = 1
        xRg1.Cells(i, j) = xRg2.Cells(i + xx, j)
        End If
         xRg2.Cells(i + xx, j) = Temp
          xx = xx + 1
     End If
    Next

    Next
'==============================
End Sub

 

[moh.elmadany]

ألا يمكن يا فندم التعديل على الماكرو الأصلي الي وضعته حضرتك
لانه قوي جدا ولا ينقصه ألا تلك النقطة

وشكرا يا فندم - في الماكرو الذي وضعته ..

 لكن هل عمود i هو عمود المصدر (مصدر الاسماء)؟

تم تعديل أبريل 14, 2018 بواسطه moh.elmadany

[سليم حاصبيا]

تم معالجة الامر

test_salim_without repetition.xlsm

[moh.elmadany]

مع الأسف يا فندم - مازالت مشكلة التكرار في نفس الصف كما هي 
 

ياريت لو فيه معيار للتكرار - يعني التكرار يكون بعد رقم صفوف معين

 

تم تعديل أبريل 15, 2018 بواسطه moh.elmadany

[moh.elmadany]

حضرتك موجود يا أستاذنا؟؟

سبق و قلت لك (اننا نتعامل مع اعداد عشوائية لذلك يمكن ان يتكرر اي صف ولا يمكن السيطرة على هذه الحالة)

ما الضرر اذن ان تقوم بكبسة زر اخرى كي لا يكون اول صف متكرر

[moh.elmadany]

المشكلة حضرتك ان الصف بالطريقة دي بيتكرر فيه الاسم احيانا لاكثر من عشر مرات !

ووفقا لقانون العمل .. لابد ان لا يتكرر الا بعد انتهاء كل الاسماء 

تم تعديل أبريل 15, 2018 بواسطه moh.elmadany