اذهب الي المحتوي
أوفيسنا

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

مصطفى محمود مصطفى
 مشاركة

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

مصطفى محمود مصطفى

مصطفى محمود مصطفى

قام بنشر
قام بنشر (معدل)

السلام عليكم

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

=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

تم تعديل بواسطه مصطفى محمود مصطفى
مصطفى محمود مصطفى

مصطفى محمود مصطفى

قام بنشر
  • الكاتب
قام بنشر (معدل)

السلام عليكم

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

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

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

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

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

ياسر خليل أبو البراء

قام بنشر
قام بنشر

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

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

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

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

  • Like 2
مصطفى محمود مصطفى

مصطفى محمود مصطفى

قام بنشر
  • الكاتب
قام بنشر (معدل)

السلام عليكم

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

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

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

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

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

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

تم تعديل بواسطه مصطفى محمود مصطفى
ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

أخي مصطفى

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

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

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

 

  • Like 1
ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

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

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

 

مصطفى محمود مصطفى

مصطفى محمود مصطفى

قام بنشر
  • الكاتب
قام بنشر

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

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

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

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

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

ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

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

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

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

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

تقبل تحياتي

  • Like 1
مصطفى محمود مصطفى

مصطفى محمود مصطفى

قام بنشر
  • الكاتب
قام بنشر

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

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

وفقكم الله

 

ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

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

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

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

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

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

  • Like 1

انشئ حساب جديد او قم بتسجيل دخولك لتتمكن من اضافه تعليق جديد

يجب ان تكون عضوا لدينا لتتمكن من التعليق

انشئ حساب جديد

سجل حسابك الجديد لدينا في الموقع بمنتهي السهوله .

سجل حساب جديد

تسجيل دخول

هل تمتلك حساب بالفعل ؟ سجل دخولك من هنا.

سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع
×
×
  • اضف...

Important Information

  I accept