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

تعديل كود الأستاذ ياسر

أبو عبد الملك السوفي
 مشاركة

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

أبو عبد الملك السوفي

أبو عبد الملك السوفي

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

السلام عليكم أساتذتنا الكرام

أريد إدخال تعديل بسيط في كود الاستاذ ياسر في برنامج المدرسة القرآنية الكود يعمل بشكل ممتاز جدا ولكن اريد ان ادخل عليه اضافة بسيطة لتسهيل العمل أكثر

العديل في صفحة التقرير الشهري

واريد من الكود أن يستقدم العمودين    M   L  من صفحة مجمع النتائج الشهرية بالاعتماد على ما هو مكتوب في العمود V 

مثلا:

اريد استقدام  نتائج الطالب عبد العزيز بن محمد سايح

فاذا كان العمود V   في صفحة التقرير الشهري مكتوب فيه أكتوبر

فان الكود ينتقل لصفحة مجمع النتائج وبالضبط العمود V  ويبحث عن الشهر الذي قبل أكتوبر وهو سبتمبر

فاذا كان الطالب تحصل في العمود العمود R على 60 فما فوق فيأخذ السورة والآية  المكتوبة في العمو ين   O   N  الى العمودين M   L في صفحة التقرير الشهري

واذا كان الطالب تحصل في العمود العمود R على أقل من 60  فيأخذ السورة والآية  المكتوبة في العمو ين   M   L  الى العمودين M   L في صفحة التقرير الشهري

هذا رابط الملف: http://rdownload.org/8brjxin90jzq/Copy_of_______________________________________.xlsm.html

رابط هذا التعليق
شارك
أبو عبد الملك السوفي

أبو عبد الملك السوفي

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

السلام عليكم

لم استطع رفع الملف هنا في الموقع فهو يقول ان الملف كبير

هذا رابط آخر http://www.up-00.com/?2WbL

تم تعديل بواسطه أبو عبد الملك السوفي
رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

السلام عليكم

اخي الكريم ابو عبدالملك

اعلم ان التعديل يأخذ جهد مضاعف

 اذا اردت التفاعل من الاعضاء مع طرحك

 يفضل طلب عمل منفصل لكي يسهل العمل

     على من اراد المشاركه 

   عموماً اطلعت على ملفك لاحظت ان عمود V في التقرير الشهري فارغ

   وانت طرحت التالي

اقتباس

فاذا كان العمود V   في صفحة التقرير الشهري مكتوب فيه أكتوبر

 فكيف نحطه كشرط ضمن الكود وهو فارغ فابطبع لن ينفذ شيء الكود !

        تفضل الكود التالي بعد ان تضيف الشهر في عمود V بصفحة التقرير الشهري

        قم بتشغيله كي يعمل معك 

       

Sub Ali_Am()
Dim Sht As Worksheet
Dim R&, Tx$
Set Sht = Sheets("مجمع النتائج الشهرية")
''**************************************
With Sheets("التقرير الشهري")
        For R = 2 To LR
                Tx = CStr(Sht.Cells(R, 3))
                If Tx = .Cells(R, 3) Then
                  If Ch_Month(.Cells(R, "V")) = CStr(Sht.Cells(R, "V")) Then
                   If SH.Cells(R, "R") >= 60 Then
                    .Cells(R, "L") = Sht.Cells(R, "N")
                    .Cells(R, "M") = Sht.Cells(R, "O")
                    ElseIf SH.Cells(R, "R") < 60 Then
                    .Cells(R, "L") = Sht.Cells(R, "L")
                    .Cells(R, "M") = Sht.Cells(R, "M")
                   End If
                  End If
                End If
       Next
End With
''**************************************
End Sub
Private Function Ch_Month(Mn As String)
Dim Mm&
Dim Tn$, X$
For Mm = 1 To 12
Tn = MonthName(Mm)
 If Tn = Trim(Mn) Then
   Mm = Mm - 1
   X = MonthName(Mm)
   Exit For
   End If
Next
If Mm Then Ch_Month = X
End Function

لم اجرب الكود اذا به اي اخطاء اشعرنا وان شاء الله لن يقصر معك الجميع

     تحياتي

  • Like 2
رابط هذا التعليق
شارك
أبو عبد الملك السوفي

أبو عبد الملك السوفي

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

السلام عليكم

 آسف على التأخر في الرد

أولا شكرا على الاهتمام

ثانيا

الكود لم يعمل لا أدري ما السبب

كود الاستاذ ياسر يعمل لكن هذا الكود لا يعمل

 

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

السلام عليكم

اقتباس

فاذا كان العمود V   في صفحة التقرير الشهري مكتوب فيه أكتوبر

عمود V فارغ حسب مرفقك 

والكود الذي نشرته انا يعتبر الى كود الاخ والاستاذ ياسر خليل

     لذا حط اسم الشهر في العمود V ونفذ الكود 

    تحياتي

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

الكود الاول به خطاء

هذا هو بعد التعديل 

Sub Ali_Am()
Dim Sht As Worksheet
Dim R&, Tx$
Set Sht = Sheets("مجمع النتائج الشهرية")
''**************************************
With Sheets("التقرير الشهري")
        LR = .Cells(.Rows.counr, 2).End(xlUp).Row
        For R = 2 To LR
                Tx = CStr(Sht.Cells(R, 3))
                If Tx = .Cells(R, 3) Then
                  If Ch_Month(.Cells(R, "V")) = CStr(Sht.Cells(R, "V")) Then
                   If SH.Cells(R, "R") >= 60 Then
                    .Cells(R, "L") = Sht.Cells(R, "N")
                    .Cells(R, "M") = Sht.Cells(R, "O")
                    ElseIf SH.Cells(R, "R") < 60 Then
                    .Cells(R, "L") = Sht.Cells(R, "L")
                    .Cells(R, "M") = Sht.Cells(R, "M")
                   End If
                  End If
                End If
       Next
End With
''**************************************
End Sub

 

رابط هذا التعليق
شارك
أبو عبد الملك السوفي

أبو عبد الملك السوفي

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

السلام عليكم

مازال الكود يظهر خطأ في السطر    

   If Ch_Month(.Cells(R, "V")) = CStr(Sht.Cells(R, "V")) Then

رغم اني كتبت الشهر

 

تم تعديل بواسطه أبو عبد الملك السوفي
رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

هل الدالة التاليه مرفقه في نفس الملف ؟ 

Private Function Ch_Month(Mn As String)
Dim Mm&
Dim Tn$, X$
For Mm = 1 To 12
Tn = MonthName(Mm)
 If Tn = Trim(Mn) Then
   Mm = Mm - 1
   X = MonthName(Mm)
   Exit For
   End If
Next
If Mm Then Ch_Month = X
End Function

 

رابط هذا التعليق
شارك
أبو عبد الملك السوفي

أبو عبد الملك السوفي

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

السلام عليكم

ارفقت الجزء الثاني من الكود ولكن بقي في الكود خطأ والآ انتقل الى السطر 

 LR = .Cells(.Rows.counr, 2).End(xlUp).Row
رابط هذا التعليق
شارك
أبو عبد الملك السوفي

أبو عبد الملك السوفي

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

السلام عليكم

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

هناك شيئ ربما نسيته

الاشهر مكتوبة في صفحة الفصول وهي مخفية

رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

السلام عليكم

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

ومزيد من الشرح وان شاء الله يتم العمل عليه 

  تحياتي

رابط هذا التعليق
شارك
أبو عبد الملك السوفي

أبو عبد الملك السوفي

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

السلام عليكم

جزاكم الله كل خير الاستاذ العيدروس والاستاذ ياسر

أعيد ان شاء الله شرح المطلوب مرة اخرى:

الفكرة:

مثلا اذا كان لدينا طالب حفظ في شهر سبتمبر من الناس1  الى  العاديات5 في آخر شهر سبتمبر نقيم له اختبار  ونعطيه درجة من 100 فاذا تحصل على 60 درجة فما فوق فانه في شهر اكتوبر يكمل حفظه أي من العاديات6  واذا تحصل على على اقل من 60 فانه يعيد الحفظ من الناس1

ونفعل هذا كل نهاية شهر

المطلوب:

حساب درجة االطالب في نهاية الشهر تتم في صفحة التقرير الشهر

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

ولمطلوب من الكود عند بداية الشهر في صفحة التقرير الشهري (العمودV ) يتاكد الكود من درجة الطالب للشهر الذي قبله في صفحة مجمع النتئج الشهرية (العمودR ) فاذاكات 60 او اكثر ياخذ ما في العمودين O N

ويكتبهما في العمودين M L في صفحة التقرير الشهري

واذا كانت

درجة الطالب للشهر الذي قبله في صفحة مجمع النتئج الشهرية (العمودR )     اقل من 60   ياخذ ما في العمودين M L

ويكتبهما في العمودين M L في صفحة التقرير الشهري

بداية الشهر: نعني ببداية الشهر اي بعد ترحيل البيانات لصفحة مجمع النتائج الشهرية ونبدأ نكتب معلومات الشهر الموالي

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

Sub CopyDataFromRecordInf()
    Dim WS As Worksheet, SH As Worksheet
    Dim LR As Long, LRCur As Long, I As Long
    Dim rngA As Range, rngB As Range, rngC As Range, rngD As Range, rngP As Range
    Dim X, Y, XX, YY
    Dim rngMnhg As Range
    
    Set WS = Sheets("ãÚáæãÇÊ ÇáÊÓÌíá"): Set SH = Sheets("ÇáÊÞÑíÑ ÇáÔåÑí")
    LR = WS.Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("ÇáãäåÌ")
        LRCur = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rngA = .Range("A2:A" & LRCur): Set rngB = .Range("B2:B" & LRCur)
        Set rngC = .Range("C2:C" & LRCur): Set rngD = .Range("D2:D" & LRCur)
        Set rngMnhg = .Range("A2:D1000"): Set rngP = .Range("P2:P" & LRCur)
    End With
    
    Application.ScreenUpdating = False
        With SH
            SH.Range("A2:E1000,I2:K1000,R2:U1000").ClearContents
            
            For I = 2 To LR
                .Cells(I, 1) = WS.Cells(I, 1)
                .Cells(I, 2) = WS.Cells(I, 2)
                .Cells(I, 3) = WS.Cells(I, 3)
                .Cells(I, 23) = WS.Cells(I, 16)
                
                .Cells(I, 4).Formula = "=IF(" & .Cells(I, 12).Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & .Cells(I, 12).Address & ",QNames,0)),ÇáÍáÞÇÊ!$F$2:$F$6,ÇáÍáÞÇÊ!$B$2:$B$6))"
                .Cells(I, 4).Value = .Cells(I, 4).Value
                
                If .Cells(I, 16) > 5 Then
                    .Cells(I, 5) = 0
                Else
                    .Cells(I, 5) = 5 - .Cells(I, 16)
                End If
                
                If .Cells(I, 8) > 5 Then
                    .Cells(I, 9) = 0
                Else
                    .Cells(I, 9) = 15 - (3 * .Cells(I, 8))
                End If
                
                X = ValueLookUp(rngB, .Cells(I, 12).Value, rngC, rngD, .Cells(I, 13).Value, rngA)
                Y = ValueLookUp(rngB, .Cells(I, 14).Value, rngC, rngD, .Cells(I, 15).Value, rngA)
                .Cells(I, 10).Value = (Y - X) * 10
                
                If .Cells(I, 10) > 100 Then
                    .Cells(I, 11) = 10
                Else
                    .Cells(I, 11) = .Cells(I, 10) / 10
                End If
                
                .Cells(I, 18) = Application.WorksheetFunction.Sum(Range(.Cells(I, 5), .Cells(I, 7)), .Cells(I, 9), .Cells(I, 11))
                
                .Cells(I, 20) = Level(.Cells(I, 18))
                
                XX = Application.WorksheetFunction.VLookup(X + 9, rngMnhg, 2)
                YY = Application.WorksheetFunction.VLookup(X + 9, rngMnhg, 4)
                .Cells(I, 21) = XX & " " & YY
            
            Next I
            
            Call RankMultipleColumns
            .Range("A1").Select
        End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Public Function ValueLookUp(ByVal NameRange As Range, sName As String, _
                            FromRange As Range, ToRange As Range, _
                            MonthValue As Integer, _
                            ResultRange As Range) As Long
'=ValueLookUp($B$2:$B$20,H6,$C$2:$C$20,$D$2:$D$20,I6,$A$2:$A$20)
'---------------------------------------------------------------
    Dim Cell As Range
    Dim I As Long, iIndex As Long, J As Long
    Dim ColIndex As Collection: Set ColIndex = New Collection

    I = 1
    iIndex = 1

    For Each Cell In NameRange
        If Cell.Value = sName Then
            ColIndex.Add I, CStr(iIndex)

            iIndex = iIndex + 1
        End If
        I = I + 1
    Next Cell

    For J = 1 To ColIndex.Count
        If MonthValue >= FromRange.Item(ColIndex.Item(J), 1) And ToRange.Item(ColIndex.Item(J), 1) >= MonthValue Then
            ValueLookUp = ResultRange.Item(ColIndex.Item(J), 1)
            Exit Function
        End If
    Next J

End Function

معذرة على الاطالة

هذا رابط الملفhttp://www.up-00.com/?UOxL

واسف مرة أخرى على الازعاج فانا اعلم ان الموضوع شائك قليلا

تم تعديل بواسطه أبو عبد الملك السوفي
رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

السلام عليكم

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

Option Explicit

Sub CopyDataFromRecordInf()
    Dim WS As Worksheet, SH As Worksheet
    Dim LR As Long, LRCur As Long, I As Long
    Dim rngA As Range, rngB As Range, rngC As Range, rngD As Range, rngP As Range
    Dim X, Y, XX, YY
    Dim rngMnhg As Range
    
    Set WS = Sheets("معلومات التسجيل"): Set SH = Sheets("التقرير الشهري")
    LR = WS.Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("المنهج")
        LRCur = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rngA = .Range("A2:A" & LRCur): Set rngB = .Range("B2:B" & LRCur)
        Set rngC = .Range("C2:C" & LRCur): Set rngD = .Range("D2:D" & LRCur)
        Set rngMnhg = .Range("A2:D1000"): Set rngP = .Range("P2:P" & LRCur)
    End With
    
    Application.ScreenUpdating = False
        With SH
            SH.Range("A2:E1000,I2:K1000,R2:U1000").ClearContents
            
            For I = 2 To LR
                .Cells(I, 1) = WS.Cells(I, 1)
                .Cells(I, 2) = WS.Cells(I, 2)
                .Cells(I, 3) = WS.Cells(I, 3)
                .Cells(I, 23) = WS.Cells(I, 16)
                
                .Cells(I, 4).Formula = "=IF(" & .Cells(I, 12).Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & .Cells(I, 12).Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$B$2:$B$6))"
                .Cells(I, 4).Value = .Cells(I, 4).Value
                
                If .Cells(I, 16) > 5 Then
                    .Cells(I, 5) = 0
                Else
                    .Cells(I, 5) = 5 - .Cells(I, 16)
                End If
                
                If .Cells(I, 8) > 5 Then
                    .Cells(I, 9) = 0
                Else
                    .Cells(I, 9) = 15 - (3 * .Cells(I, 8))
                End If
                
                X = ValueLookUp(rngB, .Cells(I, 12).Value, rngC, rngD, .Cells(I, 13).Value, rngA)
                Y = ValueLookUp(rngB, .Cells(I, 14).Value, rngC, rngD, .Cells(I, 15).Value, rngA)
                .Cells(I, 10).Value = (Y - X) * 10
                
                If .Cells(I, 10) > 100 Then
                    .Cells(I, 11) = 10
                Else
                    .Cells(I, 11) = .Cells(I, 10) / 10
                End If
                
                .Cells(I, 18) = Application.WorksheetFunction.Sum(Range(.Cells(I, 5), .Cells(I, 7)), .Cells(I, 9), .Cells(I, 11))
                
                .Cells(I, 20) = Level(.Cells(I, 18))
                
                XX = Application.WorksheetFunction.VLookup(X + 9, rngMnhg, 2)
                YY = Application.WorksheetFunction.VLookup(X + 9, rngMnhg, 4)
                .Cells(I, 21) = XX & " " & YY
            
            Next I
            
            Call RankMultipleColumns
            Call Ali_Am
            .Range("A1").Select
        End With
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Public Function ValueLookUp(ByVal NameRange As Range, sName As String, _
                            FromRange As Range, ToRange As Range, _
                            MonthValue As Integer, _
                            ResultRange As Range) As Long
'=ValueLookUp($B$2:$B$20,H6,$C$2:$C$20,$D$2:$D$20,I6,$A$2:$A$20)
'---------------------------------------------------------------
    Dim Cell As Range
    Dim I As Long, iIndex As Long, J As Long
    Dim ColIndex As Collection: Set ColIndex = New Collection

    I = 1
    iIndex = 1

    For Each Cell In NameRange
        If Cell.Value = sName Then
            ColIndex.Add I, CStr(iIndex)

            iIndex = iIndex + 1
        End If
        I = I + 1
    Next Cell

    For J = 1 To ColIndex.Count
        If MonthValue >= FromRange.Item(ColIndex.Item(J), 1) And ToRange.Item(ColIndex.Item(J), 1) >= MonthValue Then
            ValueLookUp = ResultRange.Item(ColIndex.Item(J), 1)
            Exit Function
        End If
    Next J

End Function
Private Sub Ali_Am()
Dim Sht As Worksheet
Dim R&, RR&, Tx$, LR&
Set Sht = Sheets("مجمع النتائج الشهرية")
''**************************************
With Sheets("التقرير الشهري")
        LR = .Cells(.Rows.Count, 3).End(xlUp).Row
        For R = 2 To LR
              For RR = 2 To Sht.Cells(Rows.Count, 3).End(xlUp).Row
                If CStr(Sht.Cells(RR, 3)) = .Cells(R, 3) And _
                CStr(Trim(Sht.Cells(RR, 4))) = Trim(.Cells(R, 4)) Then
                  If Ch_Month(.Cells(R, "V")) = CStr(Sht.Cells(RR, "V")) Then
                   If Sht.Cells(RR, "R") >= 60 Then
                    .Cells(R, "L") = Sht.Cells(RR, "N")
                    .Cells(R, "M") = Sht.Cells(RR, "O")
                    ElseIf Sht.Cells(RR, "R") < 60 Then
                    .Cells(R, "L") = Sht.Cells(RR, "L")
                    .Cells(R, "M") = Sht.Cells(RR, "M")
                   End If
                  End If
                End If
               Next RR
       Next R
End With
''**************************************
End Sub
Private Function Ch_Month(Mn As String)
Dim Mm&
Dim Tn$, X$
For Mm = 1 To 12
Tn = MonthName(Mm)
 If Tn = Trim(Mn) Then
   Mm = Mm - 1
   X = MonthName(Mm)
   Exit For
   End If
Next
If Mm Then Ch_Month = X
End Function

تحياتي

تم تعديل بواسطه الـعيدروس
رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

السلام عليكم

الكود المسمى "CopyDataFromRecordInf" لايجلب "الحلقة"

هذين السطرين لم تعمل عندي 

                .Cells(I, 4).Formula = "=IF(" & .Cells(I, 12).Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & .Cells(I, 12).Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$B$2:$B$6))"
                .Cells(I, 4).Value = .Cells(I, 4).Value

امل ان لاتعيق عمل الكود الاخير عندك

لان الحلقة تعتبر شرط السببفي اسماء مكرره في ورقة "مجمع النتائج الشهرية" لأكثر من حلقة

    وفي "التقرير الشهري" مره واحده لحلقة معينه

    لذا ان صادفتك نفس المشكله اشعرنا 

     لنتتبع الخطاء المذكور في الكود 

      

رابط هذا التعليق
شارك
أبو عبد الملك السوفي

أبو عبد الملك السوفي

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

السلام عليكم

الاستاذ الفاضل

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

وكنت قبل اكتبها يدويا

وللاسف الكود لم يعمل اي لم يجلب الاعمدة المطلوبة

ان كان جمع الكودين صعب فلا حرج في فصلهما

او يجب ان يقوم الكود بجلب عمودي الحفظ  M L قبل ان يسمي الحلقة

تم تعديل بواسطه أبو عبد الملك السوفي
رابط هذا التعليق
شارك
الـعيدروس

الـعيدروس

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

حاول بهذا التعديل 

Sub CopyDataFromRecordInf()
    Dim WS As Worksheet, SH As Worksheet
    Dim LR As Long, LRCur As Long, I As Long
    Dim rngA As Range, rngB As Range, rngC As Range, rngD As Range, rngP As Range
    Dim X, Y, XX, YY
    Dim rngMnhg As Range
    Dim Sht As Worksheet
    Set Sht = Sheets("مجمع النتائج الشهرية")
    Set WS = Sheets("معلومات التسجيل"): Set SH = Sheets("التقرير الشهري")
    LR = WS.Cells(Rows.Count, 1).End(xlUp).Row
    With Sheets("المنهج")
        LRCur = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rngA = .Range("A2:A" & LRCur): Set rngB = .Range("B2:B" & LRCur)
        Set rngC = .Range("C2:C" & LRCur): Set rngD = .Range("D2:D" & LRCur)
        Set rngMnhg = .Range("A2:D1000"): Set rngP = .Range("P2:P" & LRCur)
    End With
    Application.ScreenUpdating = False
        With SH
        SH.Range("A2:E1000,I2:K1000,R2:U1000").ClearContents
        For R = 2 To LR
                .Cells(R, 1) = WS.Cells(R, 1)
                .Cells(R, 2) = WS.Cells(R, 2)
                .Cells(R, 3) = WS.Cells(R, 3)
                .Cells(R, 23) = WS.Cells(R, 16)
                If .Cells(R, 16) > 5 Then
                    .Cells(R, 5) = 0
                Else
                    .Cells(R, 5) = 5 - .Cells(R, 16)
                End If
                If .Cells(R, 8) > 5 Then
                    .Cells(R, 9) = 0
                Else
                    .Cells(R, 9) = 15 - (3 * .Cells(R, 8))
                End If
                X = ValueLookUp(rngB, .Cells(R, 12).Value, rngC, rngD, .Cells(R, 13).Value, rngA)
                Y = ValueLookUp(rngB, .Cells(R, 14).Value, rngC, rngD, .Cells(R, 15).Value, rngA)
                .Cells(R, 10).Value = (Y - X) * 10
                If .Cells(R, 10) > 100 Then
                    .Cells(R, 11) = 10
                Else
                    .Cells(R, 11) = .Cells(R, 10) / 10
                End If
                .Cells(R, 18) = Application.WorksheetFunction.Sum(Range(.Cells(R, 5), .Cells(R, 7)), .Cells(R, 9), .Cells(R, 11))
                .Cells(R, 20) = Level(.Cells(R, 18))
                If CStr(Sht.Cells(R, 3)) = .Cells(R, 3) Then
                  If Ch_Month(.Cells(R, "V")) = CStr(Sht.Cells(R, "V")) Then
                   If Sht.Cells(R, "R") >= 60 Then
                    .Cells(R, "L") = Sht.Cells(R, "N")
                    .Cells(R, "M") = Sht.Cells(R, "O")
                       ElseIf Sht.Cells(R, "R") < 60 Then
                    .Cells(R, "L") = Sht.Cells(R, "L")
                    .Cells(R, "M") = Sht.Cells(R, "M")
                   End If
                  End If
                End If
                XX = Application.WorksheetFunction.VLookup(X + 9, rngMnhg, 2)
                YY = Application.WorksheetFunction.VLookup(X + 9, rngMnhg, 4)
                .Cells(R, 21) = XX & " " & YY
                .Cells(R, 4).Formula = "=IF(" & .Cells(R, 12).Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & .Cells(R, 12).Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$B$2:$B$6))"
                .Cells(R, 4).Value = .Cells(R, 4).Value
        Next R
        Call RankMultipleColumns
            .Range("A1").Select
        End With
    Set Sht = Nothing
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
Public Function ValueLookUp(ByVal NameRange As Range, sName As String, _
                            FromRange As Range, ToRange As Range, _
                            MonthValue As Integer, _
                            ResultRange As Range) As Long
'=ValueLookUp($B$2:$B$20,H6,$C$2:$C$20,$D$2:$D$20,I6,$A$2:$A$20)
'---------------------------------------------------------------
    Dim Cell As Range
    Dim I As Long, iIndex As Long, J As Long
    Dim ColIndex As Collection: Set ColIndex = New Collection

    I = 1
    iIndex = 1

    For Each Cell In NameRange
        If Cell.Value = sName Then
            ColIndex.Add I, CStr(iIndex)

            iIndex = iIndex + 1
        End If
        I = I + 1
    Next Cell

    For J = 1 To ColIndex.Count
        If MonthValue >= FromRange.Item(ColIndex.Item(J), 1) And ToRange.Item(ColIndex.Item(J), 1) >= MonthValue Then
            ValueLookUp = ResultRange.Item(ColIndex.Item(J), 1)
            Exit Function
        End If
    Next J

End Function
Private Function Ch_Month(Mn As String)
Dim Mm&
Dim Tn$, X$
For Mm = 1 To 12
Tn = MonthName(Mm)
 If Tn = Trim(Mn) Then
   Mm = Mm - 1
     X = MonthName(Mm)
     Exit For
   End If
Next
If Mm Then Ch_Month = X
End Function

 

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

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept