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

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

السلام عليكم
يظهر خطأ في السطر

 For R = 2 To LR

اضن ان المتغير  R  غير معرف

 

 

حسننا صححة الخطأ لكن الكود لم يجلب عمودي الحفظ

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

[الـعيدروس]

اي اعمده تقصد الحفظ

 

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

اتعبتك معي استاذ

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

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

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

[الـعيدروس]

هل النتائج التي في الصورة سليمه

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

السلام عليكم

النتائج التي في الصورة سليمة وها هو المطلوب

[الـعيدروس]

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

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)
                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))
                .Cells(I, "L") = Ali_C(CStr(.Cells(I, 22)), CStr(.Cells(I, 3)), 1)
                .Cells(I, "M") = Ali_C(CStr(.Cells(I, 22)), CStr(.Cells(I, 3)), 2)
                .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
                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
Private Function Ali_C(Moth$, Nm$, N&)
Dim Sht As Worksheet
Dim R
Set Sht = Sheets("مجمع النتائج الشهرية")
With Sht
For R = 2 To .Cells(.Rows.Count, 3).End(xlUp).Row
    If Trim(CStr(.Cells(R, 3))) = Trim(Nm) Then
        If Ch_Month(Moth) = CStr(.Cells(R, "V")) Then
            If .Cells(R, "R") >= 60 Then
               Select Case N
                      Case Is = 1
                           Ali_C = .Cells(R, "N")
                      Case Else
                           Ali_C = .Cells(R, "O")
                End Select
                Exit Function
             ElseIf .Cells(R, "R") < 60 Then
               Select Case N
                      Case Is = 1
                           Ali_C = .Cells(R, "L")
                      Case Else
                           Ali_C = .Cells(R, "M")
                End Select
                Exit Function
            End If
        End If
    End If
Next R
End With
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
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

 

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

لم يعمل

لا ادري مالسبب

[الـعيدروس]

السلام عليكم

هذا ملفك وبه الكود اضغط زر RUN

وشاهد النتائج

برنامج تسيير المدرسة_111.rar

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

للاسف لم ينجح

 

أضن اني اكثر شخص يزعج اساتذة هذا المنتدى

 

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

هل المشكلة في الاكسل عندي

لكن الكود القديم للاستاذ ياسر يعمل بشكل ممتاز

[الـعيدروس]

شاهد النتائج عبر المرفق

ومالنتائج التي ترى ان الكود لخبطها 

 يرجا التوضيح اين وجدت اللخبطه بالضبط

  في اي عمود

 

تجربه.rar

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

الظاهر من التسجيل انه يعمل بشكل ممتاز

لكنه لم يعمل عندي

جلب كل البيانات الا البيانات المطلوبة في العودين m l

تم تعديل نوفمبر 24, 2015 بواسطه أبو عبد الملك السوفي

[الـعيدروس]

اها مالاوفيس الذي تعمل عليه 

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

2010

[الـعيدروس]

هل جربت على نفس الملف الذي ارفقته انا في المشاركه

ام نسخت الكود لملفك الاصلي ولم يعمل 

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

عملت الشيئن معا ولم يعمل

المشكل في الاضافة التي اضفتها هي فقط التي تعمل

[الـعيدروس]

صباح الخير

صراحه غريبه جربت الكود عندي وارفقت لك فيديو

  وصوره وحسب كلامك ان النتائج سليمه

   عندي الاوفيس 2007 

  ارجو من احد الاخوه الاعضاء التجربه وارفاق النتائج

 كي نعرف اين المشكله ربما تكون في جهازك فقط

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

السلام عليكم

ساجرب الكود في جهاز آخر واعطيك النتيجة

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

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

السلام عليكم

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

جربة في جهاز آخر ولم تنجح العملية

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

استاذي

هل لغة الاكسل تؤثر في البرمجة

فانا لغة البرمجة فيه فرنسية مثلا في دوال التاريخ تجد السنة année  وليست year

 

[الـعيدروس]

ربما يكون هذا السبب

جرب عدل على الكود

 

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

لكن كيف

[الـعيدروس]

في هذا الكود

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

دالة vba.MonthName

شوف وش اسمها عندك

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

السلام عليكم

لما لا تغير هذا الجزء من الكود بكود آخر يعتمد على الاشهر المكتوبة في صفحة الفصول

[الـعيدروس]

MonthName

الدالة السابقه

لإرجاع اسم الشهر حسب تسلسله

مثال :

اذا اعطيناها MonthName(1)

ستخرج لنا اسم اول شهر في السنه الذي هو "يناير"