جدول حصص جلب اسم المادة لمعلم حسب رقمه من ورقة اخرى

مصطفى محمود مصطفى · أكتوبر 23, 2015

السلام عليكم

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

=IF(SUMPRODUCT(--(مواد=FX$47))<ROWS($1:1);"";OFFSET(INDIRECT("R"&SUBSTITUTE(SUBSTITUTE(SMALL(IF(مواد=FX$47;--(ROW(مواد)&"."&COLUMN(مواد)&1));ROWS($1:1))&"#"; "1#";); "."; "C"););0;-1))

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

جلب اسم المادة.rar

تم تعديل أكتوبر 23, 2015 بواسطه مصطفى محمود مصطفى

ياسر خليل أبو البراء · أكتوبر 23, 2015

أخي الكريم المعادلة المرفقة في الملف تعمل بشكل جيد

وتعتمد المعادلة على نطاقات تمتتسميتها مسبقاً

أين المشكلة إذاً..؟

مصطفى محمود مصطفى · أكتوبر 23, 2015

السلام عليكم

استاذ ياسر جزاك الله خيرا

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

شكرا لابداء المساعدة وسرعة اجابتكم وفقكم الله

جلب اسم المادة.rar

تم تعديل أكتوبر 23, 2015 بواسطه مصطفى محمود مصطفى
اضافة شرح اكثر

مصطفى محمود مصطفى · أكتوبر 23, 2015

للرفع

ياسر خليل أبو البراء · أكتوبر 23, 2015

أخي الكريم مصطفى محمود مصطفى

إليك الملف المرفق الخاص بك .. والعمل بالأكواد بدون معادلات .. حيث أن معادلات الصفيف لا أحبذها كثيراً

يوضع الكود التالي في موديول عادي

Public Coll As New Collection

Public Function RefreshCollection() As Collection
    Dim collDummy As New Collection, ArrIn, ArrHead, I As Long, J As Long, Str1 As String, V
    Set Coll = Nothing
    With Sheet1.Range("C46").CurrentRegion
        ArrIn = .Value
        ArrHead = .Resize(1).Offset(-44).Value
        For J = 3 To UBound(ArrIn, 2) Step 2
            For I = 2 To UBound(ArrIn, 1)
                If Len(ArrIn(I, J)) Then
                    On Error Resume Next
                    Str1 = CStr(ArrIn(I, J))
                    V = Coll(Str1)
                    If Err.Number <> 0 Then
                        Set collDummy = Nothing
                        Coll.Add Key:=Str1, Item:=collDummy
                    End If
                    On Error GoTo 0
                    Coll(Str1).Add Array(ArrIn(I, J), ArrIn(I, J - 1), ArrHead(1, J - 1))
                End If
            Next I
        Next J
    End With
    Set RefreshCollection = Coll
End Function

Public Function GetData(Param As String)
    Dim ArrOut, I As Long, V1, V2
    If Coll.Count = 0 Then Set Coll = RefreshCollection()
    On Error Resume Next
    Set V1 = Coll(Param)
    If Err.Number = 0 Then
        ReDim ArrOut(1 To V1.Count, 1 To 2)
        For Each V2 In V1
            I = I + 1
            ArrOut(I, 1) = V2(1)
            ArrOut(I, 2) = V2(2)
        Next V2
        GetData = ArrOut
    End If
    On Error GoTo 0
End Function

ويوضع الكود التالي في حدث ورقة العمل المسماة حصص المعلمين

Private Sub Worksheet_Activate()
    Set Coll = RefreshCollection()
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Arr
    Application.EnableEvents = False
    Select Case Target.Address(0, 0)
        Case "H4"
            Range("G6:H1000").ClearContents
            Arr = GetData(Target.Value)
            If IsArray(Arr) Then Range("G6").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
        Case "K4"
            Range("J6:K1000").ClearContents
            Arr = GetData(Target.Value)
            If IsArray(Arr) Then Range("J6").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
    End Select
    Application.EnableEvents = True
End Sub

غير رقم المعلم في الخلايا الصفراء وفقط

تقبل تحياتي

Grab Data By Teacher's ID YasserKhalil.rar

مصطفى محمود مصطفى · أكتوبر 23, 2015

السلام عليكم

اخي ابو البراء استاذ ياسر بارك الله فيكم وجزاكم الله خيرا

عمل رائع من استاذ رائع شكرا للجهود المبذولة

وفقكم الله .. طلبي للمعادلة هو لامكانية اضافتها بسهولة حيث يوجد بعض الاحيان 25 معلم

كيف اضيف الكود على 25 معلم اين التغيير والاضافة بالكود وانا اعمل الباقي

تعبتك معاي شكرا لكم

ادراج اسم المواد لـ 25 معلم.rar

تم تعديل أكتوبر 23, 2015 بواسطه مصطفى محمود مصطفى

ياسر خليل أبو البراء · أكتوبر 23, 2015

أخي مصطفى

لم أقهم المقصود بالإضافة ؟؟؟

هل الإضافة في ورقة عام أم في ورقة الحصص؟؟

جرب أن تضيف في ورقة عام بيانات جديدة وجرب الكود مرة أخرى باختيار رقم المعلم ...

مصطفى محمود مصطفى · أكتوبر 23, 2015

السلام عليكم

اسف استاذ ياسر تعبتك معاي ارفقت ملف بالمشاركة اعلاه واضفت 25 معلم في ورقة حصص المعلمين

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

ياسر خليل أبو البراء · أكتوبر 23, 2015

قم بتغيير الكود في حدث ورقة العمل إلى الشكل التالي

Private Sub Worksheet_Activate()
    Set Coll = RefreshCollection()
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Arr, strAddress As String, lCol As Long
    If Not Intersect(Target, Union(Range("H4"), Range("K4"), Range("N4"), Range("Q4"), Range("T4"), Range("W4"), Range("Z4"), Range("AC4"), Range("AF4"), Range("AI4"), Range("AL4"), Range("AO4"), Range("AR4"), Range("AU4"), Range("AX4"), Range("BA4"), Range("BC4"), Range("BF4"), Range("BI4"), Range("BL4"), Range("BO4"), Range("BR4"), Range("BU4"), Range("BX4"), Range("CA4"))) Is Nothing Then
        Application.EnableEvents = False
            strAddress = Target.Address(0, 0)
            lCol = Range(strAddress).Column
            Range(Cells(6, lCol), Cells(1000, lCol - 1)).ClearContents
            Arr = GetData(Target.Value)
            If IsArray(Arr) Then Cells(6, lCol - 1).Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
        Application.EnableEvents = True
    End If
End Sub

مصطفى محمود مصطفى · أكتوبر 23, 2015

استاذ ابو البراء انت اكثر من رائع

كودجميل كجمال روحك المرحة والكبيرة

اشكر جهودكم وجزاكم الله خيرا

هل يمكن اضافة زر لتفعيل الكود ربما الارقام ثابته لم تتحدث حتى اعدت كتابتها من جديد

واحدة واحدة فربما انسى ولم تتحدث شكرا لصبركم وحسن استماعكم وسرعة استجابكم لطلبات الاعضاء

ياسر خليل أبو البراء · أكتوبر 23, 2015

سأحاول إن شاء الله غداُ لأني مرهق جداً الآن ..

غداً نلتقي إذا لم يتدخل أحد الأخوة ويلبي طلبك الأخير ..

بس الملف مش مضبوط بشكل كلي .. راجع الملف ستجد هناك ثلاثة أعمدة في البداية لكل معلم وبعد قليل ستجد عمودين فقط

يرجى إعادة تصميم الملف للعمل عليه بشكل أفضل

تقبل تحياتي

مصطفى محمود مصطفى · أكتوبر 23, 2015

اشكرك اخي استاذ ياسر على الملاحظة قمت باضافة عمود ثم غيرت اسماء خلايا ارقام المعلمين بالكود, والكود مضبوط حاليا

لكن ارجو اضافة زر لتحديث الكود وان شاءالله غدا وانتم بالصحة والعافية

وفقكم الله

ياسر خليل أبو البراء · أكتوبر 24, 2015

أخي الكريم مصطفى أين المرفق الجديد بعد تعديله للعمل عليه؟

مصطفى محمود مصطفى · أكتوبر 24, 2015

اشكرك اخي استاذ ياسر

هذا الملف عدلت فيه

وفقكم الله

ادراج اسم المواد لـ 25 معلم.rar

ياسر خليل أبو البراء · أكتوبر 24, 2015

أخي الكريم مصفطى

ضع الكود التالي في موديول

Public Coll As New Collection

Public Function RefreshCollection() As Collection
    Dim collDummy As New Collection, ArrIn, ArrHead, I As Long, J As Long, Str1 As String, V
    Set Coll = Nothing
    With Sheet1.Range("C46").CurrentRegion
        ArrIn = .Value
        ArrHead = .Resize(1).Offset(-44).Value
        For J = 3 To UBound(ArrIn, 2) Step 2
            For I = 2 To UBound(ArrIn, 1)
                If Len(ArrIn(I, J)) Then
                    On Error Resume Next
                    Str1 = CStr(ArrIn(I, J))
                    V = Coll(Str1)
                    If Err.Number <> 0 Then
                        Set collDummy = Nothing
                        Coll.Add Key:=Str1, Item:=collDummy
                    End If
                    On Error GoTo 0
                    Coll(Str1).Add Array(ArrIn(I, J), ArrIn(I, J - 1), ArrHead(1, J - 1))
                End If
            Next I
        Next J
    End With
    Set RefreshCollection = Coll
End Function

Public Function GetData(Param As String)
    Dim ArrOut, I As Long, V1, V2
    If Coll.Count = 0 Then Set Coll = RefreshCollection()
    On Error Resume Next
    Set V1 = Coll(Param)
    If Err.Number = 0 Then
        ReDim ArrOut(1 To V1.Count, 1 To 2)
        For Each V2 In V1
            I = I + 1
            ArrOut(I, 1) = V2(1)
            ArrOut(I, 2) = V2(2)
        Next V2
        GetData = ArrOut
    End If
    On Error GoTo 0
End Function

ثم أدرج موديول جديد وضع فيه الكود التالي

Sub UpdateAll()
    Dim I As Long, J As Long
    Application.ScreenUpdating = False
        For I = 8 To 80 Step 3
            Sheet2.Cells(4, I).Value = J + 1
            J = J + 1
        Next I
    Application.ScreenUpdating = True
End Sub

قم بإنشاء زر أو أي شكل في ورقة العمل "حصص المعلمين" ثم كليك يمين على الزر واختر Assign Macro ثم اختر الماكرو المسمى UpdateAll لربط الزر بهذا الإجراء الفرعي

وأخيراً ضع الكود التالي في حدث ورقة العمل المسماة "حصص المعلمين" ..من خلال كليك يمين على اسم ورقة العمل ثم اختر View Code والصق الكود التالي

Private Sub Worksheet_Activate()
    Set Coll = RefreshCollection()
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Arr, strAddress As String, lCol As Long
    If Not Intersect(Target, Union(Range("H4"), Range("K4"), Range("N4"), Range("Q4"), Range("T4"), Range("W4"), Range("Z4"), Range("AC4"), Range("AF4"), Range("AI4"), Range("AL4"), Range("AO4"), Range("AR4"), Range("AU4"), Range("AX4"), Range("BA4"), Range("BD4"), Range("BG4"), Range("BJ4"), Range("BM4"), Range("BP4"), Range("BS4"), Range("BV4"), Range("BY4"), Range("CB4"))) Is Nothing Then
        Application.EnableEvents = False
            strAddress = Target.Address(0, 0)
            lCol = Range(strAddress).Column
            Range(Cells(6, lCol), Cells(1000, lCol - 1)).ClearContents
            Arr = GetData(Target.Value)
            If IsArray(Arr) Then Cells(6, lCol - 1).Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
        Application.EnableEvents = True
    End If
End Sub

أرجو أن تكون الخطوات واضحة

إذا تعذر عليك الأمر سأقوم بإرفاق ملف

مصطفى محمود مصطفى · أكتوبر 24, 2015

الاستاذ ياسر ابو البراء

اشكركم على المجهود الكبير وسعة صدركم

العمل رائع جزاكم الله خيرا

تحياتي لكم واحترامي

تسجيل الدخول

جدول حصص جلب اسم المادة لمعلم حسب رقمه من ورقة اخرى

الردود الموصى بها

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

Join the conversation

محتوي مشابه

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information