كود ترحيل درجات

[2saad]

اخواني اعضاء المنتدي الكرام بعد سلام الله عليكم ورحمة الله وبركاته

المطلوب بالملف المرفقبيانات التلاميذ.xlsm

[abouelhassan]

وضح المطلوب اخى الكريم 

[2saad]

شكرا لرد حضرتك

المطلوب موجود في المرفق

المطلوب ضبط الكود بما يتلائم مع الملف

بحيث عند الضغط علي زر ( جلب وترحيل ) يقوم بجلب الفصل من  ( ملف نصف العام ) بناء علي الاختيار من القائمة المنسدلة في ( D1   و D3) ثم بعد رصد الدرجات والضغط علي الزر مرة أخري  يقوم بترحيل الدرجات الي شيت ( ملف نصف العام )   أمام الفصل الذي اخترته وهكذااختار الفصل التالي

بمعني عندما اختار الصف من القائمة المنسدلة D1 الموجودة بالورقة ( رصد الدرجات ) ثم اختار الفصل من القائمة المنسدلة D3 مثلا فصل (4 /1) ثم اضغط علي زر ( جلب وترحيل ) يقوم بنقل كل صف أمامه (4/ 1) من ورقة العمل (ملف نصف العام ) الي ورقة ( رصد درجات ) ثم أقوم برصد الدرجات للمواد الموجودة في ورقة العمل ( رصد درجات ) وبالضغط مرة أخري علي زر ( جلب وترحيل ) يقوم بترحيل الدرجات الي ورقة العمل ( ملف نصف العام ) لكل الصفوف التي أمامها فصل  (4/ 1) 

 

[abouelhassan]

للاسف اخى الملف لم يفتح

حاول تشرح لى المطلوب فى نقاط

نبتدى بالترحيل أو بالاستدعاء ونكمل البرنامج خطوة خطوة

تمام

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

جرب هدا الحل هل يناسبك  تم وضع كود لجلب البيانات وكود اخر لترحيلها للمكان المناسب على حسب ما فهمت من طلبك 

Sub Fetch_data()
Dim clé As String, SH As String
Set desWS = Sheets("رصد درجات")
SH = desWS.Range("D1").Value
 Set f = ThisWorkbook.Sheets(SH)
  Application.ScreenUpdating = False
   Tbl = f.Range("C11:R" & f.[c65000].End(xlUp).Row).Value
   clé = desWS.Range("d3"): colClé = 2
        b = arr(Tbl, clé, colClé)
        If Not IsEmpty(b) Then
        desWS.Range("C11:R" & Rows.Count).ClearContents
        desWS.[c11].Resize(UBound(b), UBound(b, 2)) = b
    Application.ScreenUpdating = True
     MsgBox "نتائج" & " " & f.Name
      Else
     MsgBox "لايوجد نتائج للشرط المعطى"
   End If
End Sub
Function arr(Tbl, clé, colClé, Optional Cpt)
   Dim r()
   Ncol = UBound(Tbl, 2)
   If IsMissing(Cpt) Then
     ReDim r(0 To Ncol - 1): For k = 0 To Ncol - 1: r(k) = k + 1: Next k
   Else
     r = Cpt
   End If
   Nr = UBound(r)
   n = 0
   For i = LBound(Tbl) To UBound(Tbl)
     If clé = Tbl(i, colClé) Or clé = "" Then n = n + 1
   Next i
   If n > 0 Then
     Dim b(): ReDim b(1 To n, 1 To UBound(r) + 1)
     n = 0
     For i = LBound(Tbl) To UBound(Tbl)
       If clé = Tbl(i, colClé) Or clé = "" Then
          n = n + 1
          For k = 0 To Nr: b(n, k + 1) = Tbl(i, r(k)): Next k
       End If
     Next i
     arr = b
   End If
End Function

 

 

 

بيانات التلاميذ 3.xlsm

تم تعديل فبراير 8 بواسطه محمد هشام.
Modify code

[2saad]

شكرا جزيلا استاذنا الكبير ( أبو الحسن - محمد هشام )

وربنا يجزيكما كل خير علي تعبكما معنا 

وشكرا لكل أعضاء المنتدي الكرام