الكود يوزع عادي ولكن يكرر الاسماء افقيا (صف) وراسيا (عمود)

[بلانك]

المطلوب داخل الملف ..... وهنال العديد من هذة البرامج ولكن يظهر بها الاخطاء في التوزيع

كود.xlsx

[Foksh]

وعليكم السلام وحمة الله وبركاته ,,

هلا شاركتنا بكود التوزيع الذي يقوم بالتوزيع ؟؟؟

 

[بلانك]

Sub Observer222()
ActiveSheet.Unprotect "0"
Dim password As String, x As Long
password = "0"
If Application.InputBox("inter password", "login") <> password Then

MsgBox "worng password", vbInformation, "error"
Exit Sub
End If
    Dim row As Integer, col As Integer, r As Integer, c As Integer, n As Integer
    Dim lr1 As Integer, lr2 As Integer, lc1 As Integer
    Dim max As Integer
    
    Application.ScreenUpdating = False

    On Error Resume Next
    
    Worksheets("ÇáÍÇÑÓ ÇáÇæá").Select
    
    lr1 = Cells(Rows.Count, 2).End(xlUp).row
    lr2 = Cells(Rows.Count, 3).End(xlUp).row
  
    lc1 = Cells(2, Columns.Count).End(xlToLeft).Column - 0

    max = (lc1 - 4) / (lr1 - 2)

    If max > Fix(max) Then max = max + 1
    
    Range(Cells(3, 4), Cells(lr2, lc1)).ClearContents
    n = Round(Application.CountBlank(Range(Cells(3, 4), Cells(lr2, lc1))) / (lr1 - 2))

    For row = 3 To lr2
        DoEvents
        For col = 4 To lc1
1:
            DoEvents
            Cells(row, col) = Application.Index(Range("b3:b" & lr1), Application.RandBetween(1, lr1 - 2))
            
            
            If Application.CountIf(Range(Cells(row, col - 1), Cells(row, col)), Cells(row, col)) <> 1 Or _
               Application.CountIf(Range(Cells(row, 4), Cells(row, lc1)), Cells(row, col)) > max Or _
               Application.CountIf(Range(Cells(3, col), Cells(lr2, col)), Cells(row, col)) <> 1 Then
                GoTo 1
            End If
2:
        Next col
    Next row

    For c = 3 To lr1
        DoEvents
        Cells(c, 1) = Application.CountIf(Range(Cells(3, 4), Cells(lr2, lc1)), Cells(c, 2))
    Next

    Application.ScreenUpdating = True
    MsgBox "Done"
    ActiveSheet.Protect "0"
End Sub