ارجو المساعدة فى كود خاص بالاستاذ الحسامى اريد تعديل الكود لمرحلة اخرى

[أسامة عطاالله]

السلام عليكم
ارجو المساعدة فى كود للاستاذ الحسامى  قام الاخ الفاضل بعمل الكود ويعمل بشكل ممتاز لاستخراج جدول المعلم
حاولت تعديل الكود لاستخراج المواد فى صفحة المواد ولم تفلح
ارجو من سيادتكم عمل الكود فى صفحة مواد
وانا موضح فى صفحة المواد طريقة ظهور المواد
وهذا الاستخراج من صفحة ( كشاف )
ولكم جزيل الشكر
 

جدول الصف الاول.rar

[أسامة عطاالله]

للرفع

[أسامة عطاالله]

الاخوة الكرام

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

 فى الملف المرفق سابقا

فاذا تكرم احد الاساتذة الكرام فى شرح هذا الكود او عمل كود لاستخراج جدول المواد

الكود

 

Sub Techers_List()
Application.ScreenUpdating = False
Dim X As Long, X1 As Long
[D8:K19] = Empty
With sheet4
    For K = 4 To 44 Step 8
        For J = 1 To 8
            For I = 5 To 105 Step 2
                If [G5] = .Cells(I, J + K - 1) Then
                    X = Application.WorksheetFunction.Match(.Cells(1, K), [C7:C19], 0) / 2
                    X1 = Application.WorksheetFunction.Match(.Cells(2, J + K - 1), [D7:K7], 0)
                    Cells(X * 2 + 6, X1 + 3) = .Cells(I - 1, J + K - 1)
                    Cells(X * 2 + 7, X1 + 3) = .Cells(I - 1, 2)
                End If
            Next I
        Next J
    Next K
End With
End Sub

[أسامة عطاالله]

للرفع

[أسامة عطاالله]

للرفع

[أسامة عطاالله]

للرفع

اسف لكثرة رفع الموضع

اسف مرة اخرى على ازعاجكم ولكن اريد شرح للكود

وهل ينفع نفس الكود لجلب جدول المواد

واية الى مخلى الكود بيبحث فى الاسماء فقط

[أسامة عطاالله]

للرفع

 

[الـعيدروس]

السلام عليكم

 

جرب هذا التعديل

Sub Techers_List()
Application.ScreenUpdating = False
Dim X1 As Long, X As Long
[C7:Av50] = Empty
With Sheet4
.Range("D4:Av50").Value = Application.Trim(.Range("D4:Av50").Value)
        For J = 4 To 48
            For i = 4 To 35 Step 2
             If .Cells(i, J) <> "" Then
                If [I2] = .Cells(i, J).Value Then
                  Cells(i + 1, J - 1) = .Cells(i, J)
                  Cells(i + 2, J - 1) = .Cells(i, 2)
                End If
             End If
            Next i
        Next J
End With
End Sub

[أسامة عطاالله]

جزاك الله خيرا اخى العزيز

كود فعال بس للاسف السطر الاول لا يظهر

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

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

ولك جزيل الشكر اخى ويجعلة في ميزان حسناتك

 

[الـعيدروس]

السلام عليكم

 

جرب هكذا

Public Sub Ali()
With Sheet4
[C7:Av50] = Empty
.Range("D4:Av50").Value = Application.Trim(.Range("D4:Av50").Value)
For C = 4 To 50
   For Each R In .Range("D" & C & ":AV" & C)
    If R <> "" And R = [I2] Then
      Rr = Cells(Rows.Count, R.Column).End(xlUp).Offset(1, 0).Row
      Cells(Rr, R.Column - 1).Value = R.Value
      Cells(Rr + 1, R.Column - 1).Value = .Cells(R.Row, 2).Value
    End If
  Next
Next
End With
End Sub

[الـعيدروس]

Public Sub Ali()
With Sheet4
[C7:Av50] = Empty
' الغاء المسافات بين الشرط في ورقة كشاف
.Range("D4:Av50").Value = Application.Trim(.Range("D4:Av50").Value)
' حلقة تكرارية بين اعمدة ايام الأسبوع   عمود 4 : عمود 50
For C = 4 To 50
' حلقة تكرارية بين صفوف اعمدة الايام
   For Each R In .Range("D" & C & ":AV" & C)
'I2 'شرط الا تكون الخليه فارغه وأن تساوي الشرط الذي في خلية
    If R <> "" And R = [I2] Then
' اخر صف به بيانات في اعمدة الايام + 1 صف
      Rr = Cells(Rows.Count, R.Column).End(xlUp).Offset(1, 0).Row
' Rr خلية اخر صف وعمود اليوم
' R.Value'لاستخراج الشرط
      Cells(Rr, R.Column - 1).Value = R.Value
' Rr + 1'اخر صف به بيانات +2
' .Cells(R.Row, 2).Value' لاستخراج الشرط من عمود 2 في ورقة كشاف من الصف الذي يوافق الشرط
      Cells(Rr + 1, R.Column - 1).Value = .Cells(R.Row, 2).Value
    End If
' نهاية حلقة المدى
  Next
' نهاية حلقة الأعمدة
Next
End With
End Sub

[أسامة عطاالله]

مجهود مشكور علية اخى  الكريم

فعلا لسانى عاجز عن الشكر

وشكرا لك على الشرح

لكن يوجد مشكلة في الكود وهى عند اضافة مادة في فصل 1 / 4 مثلا وتحتها في فصل 1 / 5 وعند استخراج المادة ياتى الفصل الى عددة اكبر الى الامام ويتلغى الاخر ولم يرحل الى الامام

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

يوجد صور للذى حدث

 

 

[أسامة عطاالله]

شكرا لك اخى العزيز

لمجهودك وتعبك معى

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

[الـعيدروس]

لاحظ بعض مرات مع تنفيذ الكود

بتظهر لديك نتائج في ورقة المواد "بشكل تاريخ"

للتغلب على المشكله

استخدم التعديل التالي

قبل نقل القيمة يقوم بتغيير تنسيق الخليه كي تكون النتائج كنص

Public Sub Ali()
Set Sh = Sheet4
With Sh
[C7:Av50] = Empty: .[D4:Av50].Value = Application.Trim(.[D4:Av50].Value)
For C = 4 To 50
   For Each R In .Range("D" & C & ":AV" & C)
    If R <> "" And R = [I2] Then
      With Cells(Rows.Count, R.Column - 1).End(xlUp)
       .Offset(1, 0) = R: .Offset(2, 0).NumberFormat = "@"
       .Offset(2, 0) = CStr(Sh.Cells(R.Row, 2))
      End With
    End If
  Next
Next
End With
End Sub

[أسامة عطاالله]

فعلا استاذى الـعيدروس

كانت تظهر معى تاريخ

ولكن تغلبت عليها بتنسيق الخلية كنص شكرا لاهتمامك ولكن الكود افضل طبعا وسوف انقل هذا الكود بدل الاول للتغلب على التاريخ نهائى

 

[الـعيدروس]

 الحمد لله