الـعيدروس

السلام عليكم ======================= تم إضافة عمود لحالة الأقساط للعملاء ======================= وزر لطباعة التقرير في فورمة التقرير الكلي ======================= المرفق الاولى شرح طريقة العمل مع الاضافة والمرفق الاخر الملف تحياتي شرح_1.rar الاقساط_Ali_12.rar

السلام عليكم شاهد المرفق Book2_Arb.rar

الاخ الفاضل حوسام عبر كود اخي حوسام المسمى "Ali_Date_F" الاخ الحبيب KHMB اشكرك على مرورك العطر وكلماتك المشجعه

صباح الخير صراحه غريبه جربت الكود عندي وارفقت لك فيديو وصوره وحسب كلامك ان النتائج سليمه عندي الاوفيس 2007 ارجو من احد الاخوه الاعضاء التجربه وارفاق النتائج كي نعرف اين المشكله ربما تكون في جهازك فقط

السلام عليكم هذا عمل مختصر ان شاء الله يفيدك المرفق الاول شرح العمل عليه والاخر الملف واي تعديلات او اضافات سنكمل معاً ان شاء الله تحياتي شرح.rar الاقساط_Ali_11.rar

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

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

شاهد النتائج عبر المرفق ومالنتائج التي ترى ان الكود لخبطها يرجا التوضيح اين وجدت اللخبطه بالضبط في اي عمود تجربه.rar

السلام عليكم هذا ملفك وبه الكود اضغط زر RUN وشاهد النتائج برنامج تسيير المدرسة_111.rar

اذا تفضل جرب هذا التعديل 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

حط تاريخ القسط في B2 وعدد الاقساط في C2 واضغط الزر تفضل المرفق الاقساط_Ali_1.rar

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

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

شاهد الشرح في المرفق شرح.rar

حاول بهذا التعديل 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

السلام عليكم الكود المسمى "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 امل ان لاتعيق عمل الكود الاخير عندك لان الحلقة تعتبر شرط السببفي اسماء مكرره في ورقة "مجمع النتائج الشهرية" لأكثر من حلقة وفي "التقرير الشهري" مره واحده لحلقة معينه لذا ان صادفتك نفس المشكله اشعرنا لنتتبع الخطاء المذكور في الكود

السلام عليكم جرب هذا التعديل 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 تحياتي

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

هل الدالة التاليه مرفقه في نفس الملف ؟ 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

الكود الاول به خطاء هذا هو بعد التعديل 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

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

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

السلام عليكم الاخ fathiahmed اهلا وسهلاً بك عضوا جديد في صرح اوفسينا التعليمي اراك اقتبست رد لم نفهم مالمراد او المطلوب وفقك الله

السلام عليكم فتحت 3 مواضيع لنفس الطلب اكتفي بكتابة للرفع افضل في موضوعك الأول انا رديت على احد مواضيعك لنفس الطلب ولم القى رد منك تحياتي

اخي الكريم حوسام ابحث في المنتدى ستجد مواضيع وبرامج كثيره لتقوم بعمل ماتريد مثال اتبع هذا الرابط http://www.officena.net/ib/topic/25542-برنامج-للاقساط/?do=findComment&comment=121002