Sub TwoList()
'هذا الكود للمحترم زيزو العجوز
'وتعديل المحترم بن عليه وتم التعديل لمتطلبات جديده
'متغيرات
'تم هذا الكود في 1/1/2008
Dim Sh As Worksheet, Main As Worksheet
Dim C As Range
Dim x, y, z, p, q
Const Presd = "رئيس شئون الطلاب /"
Const Manag = "مدير المدرسة /"
'لمنع اهتزاز الشاشه
Application.ScreenUpdating = False
'اسم الورقه المصدر
Set Main = Sheets("البيانات")
'اسم الورقه الهدف
Set Sh = Sheets("اللجان")
'خليتي رقم اللجنه
x = Sh.Range("D2").Value: y = Sh.Range("K2").Value
'رقم صف العناوين في الصفحه الهدف
p = 4: q = 4
'تفريغ مدى صفحة الهدف
Sh.Range("B5:M500") = Empty
'ازاله الحدود في صفحة الهدف
Sh.Range("B5:M500").Borders.LineStyle = xlNone
'عمود اللجنه في الورقه المصدر
For Each C In Main.Range("D4:D500")
If C.Value = x Then
p = p + 1
' ناقص واحد بدايه ترقيم المسلسل
Sh.Cells(p, 2) = p - 4
'معلومات عن اللجنه اليمنى
'السالب هو رقم العمود في صفحه المصدر الموجود يمين عود رقم اللجنه
Sh.Cells(p, 3) = C.Offset(0, 1)
Sh.Cells(p, 4) = C.Offset(0, -2)
Sh.Cells(p, 5) = C.Offset(0, -1)
Sh.Cells(p, 6) = C.Offset(0, 4)
'=======
ElseIf C.Value = y Then
'=======
'معلومات عن اللجنه اليمنى
q = q + 1
Sh.Cells(q, 9) = q - 4
Sh.Cells(q, 10) = C.Offset(0, 1)
Sh.Cells(q, 11) = C.Offset(0, -2)
Sh.Cells(q, 12) = C.Offset(0, -1)
Sh.Cells(q, 13) = C.Offset(0, 4)
End If
Next
z = IIf(p >= q, p, q)
'خليه بدايه ونهايه التسطير
' في اللجنه الاولى وحجم الخط
Sh.Range(Cells(5, 2), Cells(z, 6)).Borders.Weight = 2
'خليه بدايه ونهايه التسطير
' في اللجنه الثانيه وحجم الخط
Sh.Range(Cells(5, 9), Cells(z, 13)).Borders.Weight = 2
Sh.Range(Cells(5, 7), Cells(z + 3, 8)).Borders(xlInsideVertical).LineStyle = zlDot
Cells(z + 2, 2) = Presd: Cells(z + 3, 2) = " " & Main.Range("G1")
Cells(z + 2, 5) = Manag: Cells(z + 3, 5) = " " & Main.Range("G2")
Cells(z + 2, 9) = Presd: Cells(z + 3, 9) = " " & Main.Range("G1")
Cells(z + 2, 12) = Manag: Cells(z + 3, 12) = " " & Main.Range("G2")
'اعادة الشاشه الى ماكانت عليه
Application.ScreenUpdating = True
End Sub