برنامج لعمل كشوف الملاحظة

[محمدي عبد السميع]

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

Sub dub()
Application.ScreenUpdating = False
   On Error Resume Next
     If Sheets("data") Is Nothing Then
Sheets("source").Visible = True
    Sheets("source").Copy Before:=Sheets(3)
    ActiveSheet.Name = "data"
If ActiveSheet.Range("c3") > 3 Then
t = ActiveSheet.Range("c3") - 3
For i = 1 To t
    ActiveSheet.Columns("i:i").Select
    Selection.Copy
    Selection.Insert Shift:=xlToRight
Next
'Application.CutCopyMode = False
For n = 1 To ActiveSheet.Range("c3")
i = 11
For x = 8 To 8 + ActiveSheet.Range("c3") - 1
ActiveSheet.Cells(i, x) = "المادة" & n
n = n + 1
Next
Next
End If
    'ActiveWorkbook.Names("المواد").Delete
'tt = ActiveSheet.Range("المواد") + 2
'End If
If ActiveSheet.Range("c2") > 10 Then
t = Application.WorksheetFunction.Round(((ActiveSheet.Range("c2"))) / 2, 0) - 5
For i = 1 To t
   Application.ScreenUpdating = False
   m = ActiveSheet.Range("last1").Row - 2
   ActiveSheet.Rows(m).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown
Next
If ActiveSheet.Range("E4") = 1 Then
t = Application.WorksheetFunction.Round((ActiveSheet.Range("c2")) / 2, 0) - 5 - 1
GoTo 77
Else
t = Application.WorksheetFunction.Round((ActiveSheet.Range("c2")) / 2, 0) - 5
GoTo 77
End If
77:
For i = 1 To t
    m = ActiveSheet.Range("last2").Row - 2
   ActiveSheet.Rows(m).Select
    Selection.Copy
    Selection.Insert Shift:=xlDown

Next

End If

 x = 2
  xx = 7
  i = 12 ' بداية صف المجموعة الاولي
  y = i + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 ' 22نهاية صف المجموعة الاولي
    
    ii = 6
    yy = ii + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 '16 نهاية صف النسخ

  iii = y + 3 '25 بداية صف المجموعة الثانية
  
      If ActiveSheet.Range("d4") = 1 Then
  yyy = iii + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0)) - 1 ' 34نهاية صف المجموعة الثانية
  
Else
  yyy = iii + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0))  ' 35نهاية صف المجموعة الثانية
    End If
    
    
  iiii = yy + 1
      If ActiveSheet.Range("d4") = 1 Then
    yyyy = iiii + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0)) - 1  ' 22نهاية صف المجموعة النسخ
  
    Else
    yyyy = iiii + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0))
End If

  ActiveSheet.Range(Cells(i, xx - 1).Address, Cells(y, xx).Address).Value = Sheets("شيت البيانات").Range(Cells(ii, x - 1).Address, Cells(yy, x).Address).Value
ActiveSheet.Range(Cells(iii, xx - 1).Address, Cells(yyy, xx).Address).Value = Sheets("شيت البيانات").Range(Cells(iiii, x - 1).Address, Cells(yyyy, x).Address).Value
  Application.CutCopyMode = True
color
ActiveSheet.Range("g12").Select
    ActiveWorkbook.Names("المواد").Delete
    tt = ActiveSheet.Range("c3") + 7
mn = Cells(11, 8).Address
mo = Cells(11, tt).Address
    ActiveWorkbook.Names.Add Name:="المواد", RefersTo:=ActiveSheet.Range(mn, mo)
   Application.ScreenUpdating = False
    ActiveSheet.Range("C2:G5").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
   ActiveSheet.Range("C2").Select
   Application.ScreenUpdating = True
   Application.CutCopyMode = False

   ' ="'data'!"$C$11:$V$11
Else
If MsgBox("هل تريد الاستمرار سيتم الغاء شيت Data", vbOKCancel, "officena- Go ?") <> vbOK Then Exit Sub
Application.DisplayAlerts = False
Sheets("Data").Delete
Application.DisplayAlerts = True
End If
 Sheets("source").Visible = False
Application.ScreenUpdating = True

End Sub
Sub h1()
a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
b = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = 12  'بداية صف المجموعة الاولي
nb = Range("lastco").Column + 1
vv = Application.WorksheetFunction.Min(Range(Cells(12, a + 1).Address, Cells(b, a + 1).Address))
For i = 12 To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row
Dim Low As Double
Dim High As Double

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then
If Cells(i, xx) = "" And Cells(i - 1, xx) <> "ح" And Cells(i + 1, xx) <> "ح" And Cells(i, xx - 1) = "ح" And Cells(i, xx + 1) = "ح" And Cells(i, a + 1) < [e3] And Cells(b + 1, xx) < [d3] And Cells(b + 1, nb) < [e5] Then
 Cells(i, xx) = "ح"
 'End If
End If
End If
 End If
Next
Next
 
If Cells(b + 1, nb) < [e5] Then
vv = Application.WorksheetFunction.Min(Range(Cells(12, a + 1).Address, Cells(b, a + 1).Address))
For i = 12 To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then
If Cells(i, xx) = "" And Cells(i - 1, xx) <> "ح" And Cells(i + 1, xx) <> "ح" And Cells(i, xx - 1) = "ح" And Cells(i, xx + 1) = "ح" And Cells(i, a + 1) < [e3] And Cells(b + 1, xx) < [d3] And Cells(b + 1, nb) < [e5] Then
 Cells(i, xx) = "ح"
 'End If
 End If
End If
 End If
Next
 Next
  End If

 
 
If Cells(b + 1, nb) < [e5] Then
0:
vv = Application.WorksheetFunction.Min(Range(Cells(12, a + 1).Address, Cells(b, a + 1).Address))
For i = 12 To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then

If Cells(i, xx) = "" And Cells(i, xx + 1) <> "ح" And Cells(i, a + 1) < [e3] + 1 And Cells(b + 1, xx) < [d3] And Cells(b + 1, nb) < [e5] Then
 Cells(i, xx) = "ح"
 End If
 End If
  End If

Next
 Next
End If
 
If Cells(b + 1, nb) < [e5] Then
vv = Application.WorksheetFunction.Min(Range(Cells(12, a + 1).Address, Cells(b, a + 1).Address))
For i = 12 To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then
If Cells(i, xx) = "" And Cells(i, a + 1) < [e3] + 1 And Cells(b + 1, xx) < [d3] And Cells(b + 1, nb) < [e5] Then
 Cells(i, xx) = "ح"
 End If
 End If
  End If

Next
 Next
End If
If Cells(b + 1, nb) < [e5] Then GoTo 0





End Sub
Sub h2()
'If Range("c5") > 0 Then
a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
e = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = e + 3 'بداية صف المجموعة الثانية
If Range("E4") > 0 Then
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية
Else
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1  'نهاية صف المجموعة الثانية
End If

nb = Range("lastco").Column + 1
vv = Application.WorksheetFunction.Min(Range(Cells(c, a + 1).Address, Cells(b, a + 1).Address))
For i = c To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row
Dim Low As Double
Dim High As Double

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then
If Cells(i, xx) = "" And Cells(i - 1, xx) <> "ح" And Cells(i + 1, xx) <> "ح" And Cells(i, xx - 1) = "" And Cells(i, xx + 1) = "" And Cells(i, a + 1) < [f4] And Cells(b + 1, xx) < [d4] And Cells(b + 1, nb) < [f5] Then
 Cells(i, xx) = "ح"
 'End If
End If
End If
 End If
Next
Next
 
If Cells(b + 1, nb) < [f5] Then
vv = Application.WorksheetFunction.Min(Range(Cells(c, a + 1).Address, Cells(b, a + 1).Address))
For i = c To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then
If Cells(i, xx) = "" And Cells(i - 1, xx) <> "ح" And Cells(i + 1, xx) <> "ح" And Cells(i, xx - 1) = "" And Cells(i, xx + 1) = "" And Cells(i, a + 1) < [f4] And Cells(b + 1, xx) < [d4] And Cells(b + 1, nb) < [f5] Then
 Cells(i, xx) = "ح"
 'End If
 End If
End If
 End If
Next
 Next
  End If

 
 
If Cells(b + 1, nb) < [f5] Then
0:
vv = Application.WorksheetFunction.Min(Range(Cells(c, a + 1).Address, Cells(b, a + 1).Address))
For i = c To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then

If Cells(i, xx) = "" And Cells(i, a + 1) < [f4] + 1 And Cells(b + 1, xx) < [d4] And Cells(b + 1, nb) < [f5] Then
 Cells(i, xx) = "ح"
 End If
 End If
  End If

Next
 Next
End If
 
If Cells(b + 1, nb) < [f5] Then
vv = Application.WorksheetFunction.Min(Range(Cells(c, a + 1).Address, Cells(b, a + 1).Address))
For i = c To b
'i = vv
For x = 8 To a
If Cells(i, a + 1) = vv Then
'mn = Cells(n, x).Row
i = Cells(i, a + 1).Row

Low = 8
High = a * 2
xx = Int((High - Low) * Rnd() + Low)
'If i < 62 Then
If xx < a + 1 Then
If Cells(i, xx) = "" And Cells(i, a + 1) < [f4] + 1 And Cells(b + 1, xx) < [d4] And Cells(b + 1, nb) < [f5] Then
 Cells(i, xx) = "ح"
 End If
 End If
  End If

Next
 Next
End If
If Cells(b + 1, nb) < [f5] Then GoTo 0




End Sub
Sub h1tem()
If Range("E2") <= 0 Then Exit Sub
If Range("g1") > 1 Then
a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
b = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = 12  'بداية صف المجموعة الاولي
For Each cell In Range(Cells(12, 8).Address, Cells(b, a).Address)
If cell.Value = "" Or cell.Value = 0 Then
cell.Value = "ح"
End If
Next
End If
End Sub

Sub num1()
Dim Low As Double
Dim High As Double
[A1500] = ""
[a2000] = ""
ActiveSheet.Range("A1000") = ""
a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
b = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
0:
m = Range("h12").Address
n = Cells(b, a).Address
'If ActiveSheet.CheckBox1.Value = 0 Then
'Range(m, n) = ""
'End If
Application.ScreenUpdating = False
'h1
For x = 8 To a
For i = 12 To b
For n = 1 To [c4]
Low = n
High = [c4]
n = Round(((High - Low) * Rnd() + Low), 0)
'If r <= a Then
'If n >= 1 Then
If Cells(i, x) = "" Then
If Cells(i, x - 1) <> n Then
Range("A1500") = "=CountIf(" & Cells(i, 8).Address & ":" & Cells(i, a).Address & "," & n & ")"
Range("A2000") = "=CountIf(" & Cells(12, x).Address & ":" & Cells(b, x).Address & "," & n & ")"
v = [A1500]
v1 = [a2000]
If v = 0 And v1 = 0 Then
'On Error GoTo 88
'If Cells(i, x) = "" Then
Cells(i, x) = n
'End If
End If
'End If
End If
End If
Next
Next
Next 'tem1
For i = 12 To b
For x = 8 To a
For n = 1 To [c4]
Low = n
High = [c4]
n = Round(((High - Low) * Rnd() + Low), 0)
If Cells(i, x) = "" Then
If Cells(i, x - 1) <> n Then
Range("A1500") = "=CountIf(" & Cells(i, 8).Address & ":" & Cells(i, a).Address & "," & n & ")"
Range("A2000") = "=CountIf(" & Cells(12, x).Address & ":" & Cells(b, x).Address & "," & n & ")"
v = [A1500]
v1 = [a2000]
If v < 2 And v1 = 0 Then
Cells(i, x) = n

End If
End If
End If
Next
Next
Next 'tem1
For i = 12 To b
For x = 8 To a
For n = 1 To [c4]
If Cells(i, x) = "" Then
Range("A1500") = "=CountIf(" & Cells(i, 8).Address & ":" & Cells(i, a).Address & "," & n & ")"
Range("A2000") = "=CountIf(" & Cells(12, x).Address & ":" & Cells(b, x).Address & "," & n & ")"
v = [A1500]
v1 = [a2000]
If v <= 2 And v1 = 0 Then
Cells(i, x) = n

End If
End If
Next
Next
Next 'tem1
test
If ActiveSheet.CheckBox1.Value = False Then
If Range("bad") = 1 Then
m = Range("h12").Address
n = Cells(b, a).Address
Range(m, n) = ""
h1
GoTo 0
End If
End If
Application.ScreenUpdating = True
'End
'88:
'GoTo 1
End Sub
Sub num2()

a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = d + 3 'بداية صف المجموعة الثانية
If ActiveSheet.Range("E4") > 0 Then
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية
GoTo 10
Else
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1  'نهاية صف المجموعة الثانية
GoTo 10
End If
10:
For x = 8 To a
For i = 12 To d
For y = c To b
'If Range("E4") = 0 Then
If ActiveSheet.Cells(i, x) > 0 And ActiveSheet.Cells(i, x) <> "ح" Then

'GoTo 0
'Else
'If Range("E4") <> 0 Then
'If Cells(i, x) > 0 And Cells(i, x) <> "ح" And Cells(i, x) < Range("c4") Then
'GoTo 0
'End If
'End If
0:
bb = ActiveSheet.Cells(i, 7).Interior.ColorIndex
bc = ActiveSheet.Cells(i, 7).Font.ColorIndex
If vvvv = 1 Then GoTo 3

   v = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(y, 8).Address & ":" & ActiveSheet.Cells(y, a).Address), ActiveSheet.Cells(i, x).Value)
v1 = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(c, x).Address & ":" & ActiveSheet.Cells(b, x).Address), ActiveSheet.Cells(i, x).Value)
If v = 0 And v1 = 0 Then
Dim Low As Double
Dim High As Double

Low = c
High = b + 10
r = Int((High - Low) * Rnd() + Low)
If r >= c And r <= b Then
If ActiveSheet.Cells(r, x) = "" Then
3:
vvc = 0
For Each cell In ActiveSheet.Range(Cells(r, 8).Address, ActiveSheet.Cells(r, a).Address)
If cell.Interior.ColorIndex = bb And cell.Font.ColorIndex = bc Then
vvc = vvc + 1
End If
Next
'If Range("E4") = 0 Then
If vvc <= ActiveSheet.Range("c5") Then
'GoTo 1
'Else
'If Range("E4") <> 0 Then
'If vvc < [c5] Then
'GoTo 1
'End If
1:
ActiveSheet.Cells(r, x) = ActiveSheet.Cells(i, x)
ActiveSheet.Cells(r, x).Interior.ColorIndex = bb
ActiveSheet.Cells(r, x).Font.ColorIndex = bc
End If
End If
End If
End If
End If
'End If
'End If
'End If
Next
Next
Next
End Sub
Sub test()

a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = d + 3 'بداية صف المجموعة الثانية
If Range("E4") > 0 Then
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية
Else
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 'نهاية صف المجموعة الثانية
End If
Range("bad") = ""
i = d + 2
For x = 8 To a
If Cells(i, x) = "توزيع خاطئ" Then
Range("bad") = 1
End If
Next
'i = b + 2
'For x = 8 To a
'If Cells(i, x) = "توزيع خاطئ" Then
'Range("bad") = 1
'End If
'Next
End Sub
Sub color()

a = 8 + [c3] - 1 'عدد الاعمدة
d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1  'نهاية صف المجموعة الاولي
c = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) + 2 'بداية صف المجموعة الثانية
If Range("E4") > 0 Then
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2  'نهاية صف المجموعة الثانية
Else
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 'نهاية صف المجموعة الثانية
End If
m = Cells(12, 8).Address
n = Cells(d, a).Address
o = Cells(c, 8).Address
p = Cells(b, a).Address
For i = 12 To d
If Cells(i, 6) > 0 Then
If Cells(i, 6) > 56 Then
Cells(i, 7).Interior.ColorIndex = Cells(i, 6) - 56
Cells(i, 7).Font.ColorIndex = 3
Else
Cells(i, 7).Interior.ColorIndex = Cells(i, 6)
End If
End If
Next
Range(Cells(c, 6).Address, Cells(b, 7).Address).Interior.ColorIndex = xlNone
Range(o, p).Interior.ColorIndex = Range("g" & d).Interior.ColorIndex + 4
Range(m, n).Interior.ColorIndex = 35
Range(Cells(d + 1, 8).Address, Cells(d + 1, a).Address).Interior.ColorIndex = 37
Range(Cells(b + 1, 8).Address, Cells(b + 1, a).Address).Interior.ColorIndex = 38
End Sub
Sub tem1()
a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
b = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
i = b + 2
For x = 8 To a
If ActiveSheet.Cells(i, x) = "توزيع خاطئ" Then
For bb = 12 To b
If ActiveSheet.Cells(bb, x) = "" Or ActiveSheet.Cells(bb, x) = 0 Then
For n = 1 To ActiveSheet.Range("c4") + 10
0:
   v = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(12, x).Address & ":" & ActiveSheet.Cells(b, x).Address), n)
   v1 = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(bb, 8).Address & ":" & ActiveSheet.Cells(bb, a).Address), n)
If Range("E4") < 0 Then
If v = 0 And v1 < ActiveSheet.Range("c5") Then
If n <= ActiveSheet.Range("c4") Then
ActiveSheet.Cells(bb, x) = n
End If
End If

End If

Next
End If
Next
End If
Next
i = b + 2
For x = 8 To a
If ActiveSheet.Cells(i, x) = "توزيع خاطئ" Then
For bb = 12 To b
If ActiveSheet.Cells(bb, x) = "" Or ActiveSheet.Cells(bb, x) = 0 Then
For n = 1 To ActiveSheet.Range("c4")
1:
   v = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(12, x).Address & ":" & ActiveSheet.Cells(b, x).Address), n)
   v1 = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(bb, 8).Address & ":" & ActiveSheet.Cells(bb, a).Address), n)
If v = 0 And v1 <= [c5] + 1 Then
If n <= ActiveSheet.Range("c4") Then
If Cells(bb, Range("lastco").Row) <= Range("d3") Then
ActiveSheet.Cells(bb, x) = n
End If
End If
End If
Next
End If
Next
End If
Next
End Sub
Sub tem2()

a = 8 + [c3] - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = d + 3 'بداية صف المجموعة الثانية
If ActiveSheet.Range("E4") > 0 Then
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 2 'نهاية صف المجموعة الثانية

GoTo 10
Else
b = c + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1  'نهاية صف المجموعة الثانية
GoTo 10
End If
10:
i = b + 2
For x = 8 To a
If ActiveSheet.Cells(i, x) = "توزيع خاطئ" Then
For bb = c To b
If ActiveSheet.Cells(bb, x) = "" Or ActiveSheet.Cells(bb, x) = 0 Then
For n = 1 To [c4] + 10
If n <= ActiveSheet.Range("c4") Then
0:
   v = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(c, x).Address & ":" & ActiveSheet.Cells(b, x).Address), n)
   v1 = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(bb, 8).Address & ":" & ActiveSheet.Cells(bb, a).Address), n)
If v = 0 Then
ActiveSheet.Cells(bb, x) = n
For hh = 12 To d
If ActiveSheet.Cells(hh, x) = n Then
cc = ActiveSheet.Cells(hh, 7).Interior.ColorIndex
bc = ActiveSheet.Cells(hh, 7).Font.ColorIndex
GoTo fl
End If
Next
fl:
ActiveSheet.Cells(bb, x).Interior.ColorIndex = cc
ActiveSheet.Cells(bb, x).Font.ColorIndex = bc
End If
End If
Next
End If
Next
End If
Next
i = b + 2
For x = 8 To a
If ActiveSheet.Cells(i, x) = "توزيع خاطئ" Then
For bb = c To b
If ActiveSheet.Cells(bb, x) = "" Or ActiveSheet.Cells(bb, x) = 0 Then
For n = 1 To ActiveSheet.Range("c4") + 10
If n <= ActiveSheet.Range("c4") Then
1:
   v = Application.WorksheetFunction.CountIf(Range(Cells(c, x).Address & ":" & ActiveSheet.Cells(b, x).Address), n)
   v1 = Application.WorksheetFunction.CountIf(Range(Cells(bb, 8).Address & ":" & ActiveSheet.Cells(bb, a).Address), n)
If v = 0 And v1 <= 2 Then
ActiveSheet.Cells(bb, x) = n
For hh = 12 To d
If ActiveSheet.Cells(hh, x) = n Then
bc = ActiveSheet.Cells(hh, 7).Font.ColorIndex
cc = ActiveSheet.Cells(hh, 7).Interior.ColorIndex
GoTo cl
End If
Next
cl:
ActiveSheet.Cells(bb, x).Interior.ColorIndex = cc
ActiveSheet.Cells(bb, x).Font.ColorIndex = bc
End If
End If
Next
End If
Next
End If
Next
End Sub
Sub allone1()
m = Cells(Range("lastco").Row + 4, Range("lastco").Column + 8).Address
n = Cells(Range("lastco").Row + 200, Range("lastco").Column + 11).Address
Range(m, n) = ""
a = 3 + ActiveSheet.Range("c2") - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = d + 3 'بداية صف المجموعة الثانية
If ActiveSheet.Range("E4") > 0 Then
b = c + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 - 1) 'نهاية صف المجموعة الثانية

GoTo 10
Else
b = c + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1)  'نهاية صف المجموعة الثانية
GoTo 10
End If
10:
cf = Cells(Range("lastco").Row + 4, Range("lastco").Column + 9).Column
For x = 8 To 8 + ActiveSheet.Range("c3") - 1
For i = c To b
If Cells(i, x).Interior.ColorIndex = Cells(Range("lastco").Row + 3, Range("lastco").Column + 7) Then
With Columns(cf).Rows(1000).End(xlUp)
.Offset(1, 0) = Cells(i, 2)
.Offset(1, 1) = Cells(i, x)
.Offset(1, 2) = Cells(11, x)
End With
End If
Next
Next
For x = 8 To 8 + ActiveSheet.Range("c3") - 1
For i = 12 To d
If Cells(i, 2).Interior.ColorIndex = Cells(Range("lastco").Row + 3, Range("lastco").Column + 7) Then
Cells(Range("lastco").Row + 4, Range("lastco").Column + 8) = Cells(i, 2)
If Cells(i, x) = "ح" Then
With Columns(cf).Rows(1000).End(xlUp)
.Offset(1, 0) = "-"
.Offset(1, 1) = "ح"
.Offset(1, 2) = Cells(11, x)
End With
End If
End If
Next
Next
End Sub
Sub allone2()
m = Cells(Range("lastco").Row + 4, Range("lastco").Column + 13).Address
n = Cells(Range("lastco").Row + 200, Range("lastco").Column + 16).Address
Range(m, n) = ""
a = 8 + ActiveSheet.Range("c2") - 1 'عدد الاعمدة
  'نهاية صف المجموعة الاولي
d = 12 + Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1
c = d + 3 'بداية صف المجموعة الثانية
If ActiveSheet.Range("d4") > 0 Then
b = c + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1 - 1) 'نهاية صف المجموعة الثانية

GoTo 10
Else
b = c + (Application.WorksheetFunction.Round((ActiveSheet.Range("c2") / 2), 0) - 1)  'نهاية صف المجموعة الثانية
GoTo 10
End If
10:
cf = Cells(Range("lastco").Row + 4, Range("lastco").Column + 14).Column
For x = 8 To 8 + ActiveSheet.Range("c3") - 1
For i = c To b
If Cells(i, 1) = Cells(Range("lastco").Row + 3, Range("lastco").Column + 13) Then
Cells(Range("lastco").Row + 4, Range("lastco").Column + 13) = Cells(i, 2)
If Cells(i, x) <> "ح" Then
For n = 12 To d
If Cells(n, 7).Interior.ColorIndex = Cells(i, x).Interior.ColorIndex Then
With Columns(cf).Rows(1000).End(xlUp)
.Offset(1, 0) = Cells(n, 2)
.Offset(1, 1) = Cells(n, x)
.Offset(1, 2) = Cells(11, x)
End With
End If
Next
End If
End If

Next
Next
For x = 8 To 8 + ActiveSheet.Range("c3") - 1
For i = c To b
If Cells(i, 1) = Cells(Range("lastco").Row + 3, Range("lastco").Column + 13) Then
Cells(Range("lastco").Row + 4, Range("lastco").Column + 13) = Cells(i, 2)
If Cells(i, x) = "ح" Then
With Columns(cf).Rows(1000).End(xlUp)
.Offset(1, 0) = "-"
.Offset(1, 1) = "ح"
.Offset(1, 2) = Cells(11, x)
End With
End If
End If
Next
Next

End Sub
Sub xxxcc()
'If Target.Column = 19 And Target.Row = 9 Then
Range("t10:y210") = ""
'If Target <> "" Then
i = 11
For x = 8 To Sheets("data").Range("c2") - 1
If Sheets("data").Cells(i, x) = Sheets("شيت طبع كشف الملاحظة").Range("s9") Then
z = Sheets("data").Cells(i, x).Column
GoTo 0
End If
Next


0:
For y = 12 To d
If IsNumeric(Sheets("data").Cells(y, z)) And Sheets("data").Cells(y, z) > 0 And Sheets("data").Cells(y, 2) <> "" Then ' Sheets("شيت طبع كشف الملاحظة").Cells(yy, 1) Then
With Columns(20).Rows(210).End(xlUp)
.Offset(1, 0) = Sheets("data").Cells(y, z)
.Offset(1, 1) = Sheets("data").Cells(y, 2)
End With
End If
Next
For yyy = 12 To d
If Sheets("data").Cells(yyy, z) = "ح" Then
With Columns(22).Rows(210).End(xlUp)
.Offset(1, 0) = Sheets("data").Cells(yyy, z)
.Offset(1, 1) = Sheets("data").Cells(yyy, 2)
End With
End If
Next

End Sub
Function aahsum(aa As Variant)
f = 0
For n = 1 To aa.Value
f = f + n
Next
aahsum = f
End Function

 

برنامج ساقبة اللجان.xlsb