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