تسطير النواتج اوتوماتيك

[ناصر سعيد]

هذا الكود ياتي بالنواتج ولكننا نريد نريد ان يتم التسطير على البيانات اوتوماتيك
وان يكون بالكود بعض التنسيقات مثل حجم الخط واسمه وتوسيطه
ربنا ييسر  الامور   او يتم اخفاء الصفوف الزياده

 Sub Legan_I()
 ' فى البداية تم عمل كشاف لتوزيع اللجان فى ورقة بيانات الطلبة
 ' وتحديد بداية أرقام الجلوس ونهايتها وكذلك بداية أرقام اللجان ونهائيتها
 ' كخطوة لتهيئة العمل
' <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
   ' ' الاعلان عن المتغيرات
Dim ws As Worksheet, Sh As Worksheet
Set ws = Sheets("كشوف المناداة ")
Set Sh = Sheets("بيانات الطلبة")
Dim Arr As Variant, Arr1 As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long

' تحديد آخر سطر يحتوى على بيانات فى ورقة المصدر والذى يرتبط بعمود الأسماء رقم 5
LR = Sh.Cells(Rows.Count, 5).End(xlUp).Row
'------------------------------------
Application.ScreenUpdating = False

'  مسح محتوى البيانات المتغير فى صفحة الهدف
ws.Range("C10:F39").ClearContents

' تحديد نطاق بيانات العمل فى ورقة المصدر
Arr = Sh.Range("A7:V" & LR).Value
   Arr1 = Array(2, 5, 15, 16)
   
   ' تخزين أرقام الأعمدة المطلوب ترحيها فى مصفوفة بهذا الاسم
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)

' المعيار الذى يتم بناء عليه ترحيل البيانات وهو هنا
' العمود رقم 18 فى ورقة المصدرالذى سحتوى على أرقام اللجان
' ولابد أن يكون مساويا لقيمة رقم اللجنة الموجودة فى ورقة الهدف فى الخلية E3
If Arr(i, 18) = ws.Range("E3").Value Then
'---------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))
Next j
End If
Next i

' إذا تحقق الشرط السابق فيتم ترحيل البياناتالمخزنة فى المصفوفة إلى ورقة الهدف ابتداء من الخلية C10
If p > 0 Then ws.Range("C10").Resize(p, UBound(Temp, 2)).Value = Temp

' بذلك يكون قد تم ترحيل بيانات أول قائمة فى كشف المناداة
' ولعمل نفس الكود فى القائمة الثانية المجاورة
' قمت بعمل نفس الكود مع تغيرات بسيطة على نطاقات الخلايا الهدف
' ثم تم استدعاء الكود الثانى من خلال الكود الأول فى الخطوة التالية
'*******************************
 Call Legan_II
'******************************* '
  Application.Visible = True
 Application.ScreenUpdating = True
End Sub
'*******************************

'*******************************
' الكود الثانى لاستدعاء بيانات القائمة الثانية لكشوف المناداة
Sub Legan_II()
'===========================================
 ' فى البداية تم عمل كشاف لتوزيع اللجان فى ورقة بيانات الطلبة
 ' وتحديد بداية أرقام الجلوس ونهايتها وكذلك بداية أرقام اللجان ونهائيتها
 ' كخطوة لتهيئة العمل
' <><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><><>
   ' ' الاعلان عن المتغيرات
Dim ws As Worksheet, Sh As Worksheet
Set ws = Sheets("كشوف المناداة ")
Set Sh = Sheets("بيانات الطلبة")
Dim Arr As Variant, Arr1 As Variant, Temp As Variant
Dim LR As Long, i As Long, j As Long, p As Long

' تحديد آخر سطر يحتوى على بيانات فى ورقة المصدر والذى يرتبط بعمود الأسماء رقم 5
LR = Sh.Cells(Rows.Count, 5).End(xlUp).Row
'------------------------------------
Application.ScreenUpdating = False

'  مسح محتوى البيانات المتغير فى صفحة الهدف
ws.Range("K10:N39").ClearContents

' تحديد نطاق بيانات العمل فى ورقة المصدر
Arr = Sh.Range("A7:V" & LR).Value
   Arr1 = Array(2, 5, 15, 16)
   
   ' تخزين أرقام الأعمدة المطلوب ترحيها فى مصفوفة بهذا الاسم
ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1)
For i = 1 To UBound(Arr)

' المعيار الذى يتم بناء عليه ترحيل البيانات وهو هنا
' العمود رقم 18 فى ورقة المصدرالذى سحتوى على أرقام اللجان
' ولابد أن يكون مساويا لقيمة رقم اللجنة الموجودة فى ورقة الهدف فى الخلية E3
If Arr(i, 18) = ws.Range("M3").Value Then
'---------------------------------------
p = p + 1
For j = 0 To UBound(Arr1)
Temp(p, j) = Arr(i, Arr1(j))
Next j
End If
Next i

' إذا تحقق الشرط السابق فيتم ترحيل البياناتالمخزنة فى المصفوفة إلى ورقة الهدف ابتداء من الخلية C10
If p > 0 Then ws.Range("K10").Resize(p, UBound(Temp, 2)).Value = Temp

' بذلك يكون قد تم ترحيل بيانات تان قائمة فى كشف المناداة
 
  Application.Visible = True
 Application.ScreenUpdating = True
End Sub

 

اخفاء صفوف زائده.rar

[kalll]

السلام عليكم اخى الفاضل ناصر سعيد ممكن مساعدة 

هذا كود للبحث من شيت حركة الموردين 
كيف اجعله يجلب بيانات من شيت حركة النقدية ايضا
Sub Kh_Filter()
Dim Last As Long
Last = Worksheets(Mydate).UsedRange.Rows.Count
'-----------------------------
Worksheets(Mydate).Range("A1:D" & Last).AdvancedFilter xlFilterCopy _
, Worksheets(MyFind).Range("K2:L3"), Worksheets(MyFind).Range("A5:D5"), False
'-----------------------------
ActiveWindow.ScrollRow = 1

====================

ممكن المساعدة استاذنا 

• ناصر سعيد

وجزاك الله خير

Book3330.rar

تم تعديل أكتوبر 20, 2017 بواسطه kalll

[ناصر سعيد]

اخي

kalll

كنت اتمنى ان اساعدك ولكن ادعو الله ان يرزقك باحد الاخوة الذين يستطيعون اجابة طلبك

====================

 

======

Sub Legan_Test()
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim arr         As Variant
    Dim arrC        As Variant
    Dim temp1       As Variant
    Dim temp2       As Variant
    Dim lr          As Long
    Dim i           As Long
    Dim j           As Long
    Dim k           As Long
    Dim p1          As Long
    Dim p2          As Long

    Set ws = Sheets("بيانات الطلبة")
    Set sh = Sheets("كشوف المناداة")

    lr = ws.Cells(Rows.Count, 5).End(xlUp).Row
    
    Application.ScreenUpdating = False
        sh.Range("C10:F39").ClearContents
        sh.Range("K10:N39").ClearContents
        sh.Rows("10:39").Hidden = False
        
        arr = ws.Range("A7:V" & lr).Value
        arrC = Array(2, 5, 15, 16)
        ReDim temp1(1 To UBound(arr, 1) + 1, 0 To UBound(arrC) + 1)
        ReDim temp2(1 To UBound(arr, 1) + 1, 0 To UBound(arrC) + 1)
        
        For i = 1 To UBound(arr)
            If arr(i, 18) = sh.Range("E3").Value Then
                p1 = p1 + 1
                For j = 0 To UBound(arrC)
                    temp1(p1, j) = arr(i, arrC(j))
                Next j
            End If
            If arr(i, 18) = sh.Range("M3").Value Then
                p2 = p2 + 1
                For j = 0 To UBound(arrC)
                    temp2(p2, j) = arr(i, arrC(j))
                Next j
            End If
        Next i
    
        If p1 > 0 Then sh.Range("C10").Resize(p1, UBound(temp1, 2)).Value = temp1
        If p2 > 0 Then sh.Range("K10").Resize(p2, UBound(temp2, 2)).Value = temp2
        
        If p1 > 0 Then k = p1
        If p2 > 0 And p2 > k Then k = p2
        k = k + 10
        If k < 39 Then sh.Rows(k & ":39").Hidden = True
        
        Application.Visible = True
    Application.ScreenUpdating = True
End Sub

هذا الحل الخاص بدمج الكودين الخاصين بعمل اللجان واخفاء الصفوف الزياده

جزى الله كل من له بصمه في  اخراج هذا العمل الى النور

ونخص .. الاستاذ خالد الرشيدي والاستاذ ياسر خليل والاستاذ محمد الدسوقي وشخصنا البسيط

 

لجان كنترول مدرسي.rar