</span>
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

<span style="color:#2F4F4F">

قوائم لجنتين للمحترم زيزو العجوز 5.rar