كود للتوزيع العشوائي

[amnamohmmad]

السلام عليكم

صباح الخير ممكن حل للملف الخلية d2  أو على الماكرو وشكرا 

يتم توزيع الاسم حسب العدد في b2 التوزيع عشوائي من d2 الى h66

توزيع.xlsm

[lionheart]

Please the topic needs more details and put some of the expected output

[amnamohmmad]

السلام عليكم متاسفة على التاخير

ان شاء الله قدرت اوصل المعلومة يارب والف شكر على الرد 

توزيع.xlsm

[amnamohmmad]

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

توزيع المراقبي2.xlsm

[lionheart]

Look you have to be more logical

The total of the numbers in column B equals 331 so the final output number of the names will be 331

While the number of cells in range D2:H66 will be 65 * 5 which equals 325 so the cells that will be have the names are less than the needed names to be populated

Can you explain how will you deal with the problem in that case

[amnamohmmad]

أولا شكر لك استاذي الكريم على الرد بالنسبة للارقام التى ذكرت 65*5 (الرقم  5) فهو على سبيل المثال لا الحصر 

[lionheart]

I meant 65 rows * 5 columns (from column D to column H)

[amnamohmmad]

الخلايا 65*5(من العمود D إلى العمود H)

توزيع الاسماء بشرط ان يتكرر الاسم عشوائيا(على اساس العامود B)

امنة1 يتم توزيعها 5 مرات عشوائيا (من العمود D إلى العمود H)

امنة2 يتم توزيعها 6 مرات عشوائيا (من العمود D إلى العمود H)

حتى اخر اسم اذا تكرمت

[lionheart]

.Prepare your file with some of the expected results and please be accurate

You didn't pay attention to my replies and didn't answer to my questions

[amnamohmmad]

متاسفة على عدم توصيل المعلومة واكرر شكري لك استاذي

جهزت الملف على 23 اسم 

توزيع.xlsm

[lionheart]

Try this code

Sub Test_LionHeart()
    Dim a, b, lr As Long
    With ActiveSheet
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        .Range("D2:H" & lr).ClearContents
        a = CreateNamesArray(.Range("A2:A" & lr), .Range("B2:B" & lr))
        ShuffleArray a
        b = ConvertToColumns(a, lr - 1)
        .Range("D2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
    End With
End Sub

Function CreateNamesArray(ByVal namesRange As Range, ByVal countRange As Range)
    Dim nameArray, nameIndex As Long, countIndex As Long, rowCount As Long, totalNames As Long, currCount As Long, i As Long
    rowCount = namesRange.Rows.Count
    totalNames = WorksheetFunction.Sum(countRange)
    ReDim nameArray(1 To totalNames, 1 To 1)
    nameIndex = 1
    For countIndex = 1 To rowCount
        currCount = countRange(countIndex, 1).Value
        For i = 1 To currCount
            nameArray(nameIndex, 1) = namesRange(countIndex, 1).Value
            nameIndex = nameIndex + 1
        Next i
    Next countIndex
    CreateNamesArray = nameArray
End Function

Private Sub ShuffleArray(ByRef arr)
    Dim temp, i As Long, j As Long
    Randomize
    For i = LBound(arr) To UBound(arr)
        j = Int((UBound(arr) - i + 1) * Rnd + i)
        temp = arr(i, 1)
        arr(i, 1) = arr(j, 1)
        arr(j, 1) = temp
    Next i
End Sub

Function ConvertToColumns(ByVal inputArray, ByVal divisor As Long)
    Dim numOutputCols As Long, i As Long, j As Long, k As Long
    numOutputCols = Application.WorksheetFunction.RoundUp(UBound(inputArray, 1) / divisor, 0)
    ReDim outputArray(1 To divisor, 1 To numOutputCols)
    k = 1
    For j = 1 To numOutputCols
        For i = 1 To divisor
            If k <= UBound(inputArray, 1) Then
                outputArray(i, j) = inputArray(k, 1)
                k = k + 1
            End If
        Next i
    Next j
    ConvertToColumns = outputArray
End Function

 

[amnamohmmad]

كل الشكر والامتنان  للاستاذ الخبير lionheart على مساعدتي في إنجاز العمل بنجاح. وقد ساعدته قيِّم عطائه ، وعلمه 

ربنا ييسر امرك ويزيدك من نعيمعه فعلا اكرمتني ربي يكرمك كل الشكر والتقدير والاجلال لك أستاذي

[ميدو63]

الأستاذ الفاضل

lionheart

كود جميل وأشكرك عليع

مع رجاء توضيح أماكن التعديل في الكود - في حال اردن أن نزيد عدد اعمده التوزيع عن 5 اعمده

 

تحياتي

[lionheart]

The results will be populated to the suitable number of columns so you can't modify the number of columns in results. Try to put more names and values and you will see the output will be populated in more than five columns