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

أخي الكريم أهلا بك في المنتدى ومرحباً بك بين إخوانك ----------------------------------- يرجى تغيير اسم الظهور للغة العربية يرجى الإطلاع على رابط التوجيهات لمعرفة كيفية التعامل مع المنتدى وإرفاق ملف تقبل تحياتي

سأكرر نفس سؤالي مرة أخرى أين الخلايا التي بها التاريخين المراد العمل عليهما ..؟ يرجى إعادة رفع الملف بعد إدراج بعض النتائج المتوقعة .. طلبك سهل لكن الملف المرفق غير واضح

بسم الله ما شاء الله روعة أخي ومعلمي رؤوف بارك الله فيك .. سأنتظر شرح فيديو لخطوات العمل بالتفصيل ليستفيد منه الجميع .. مللنا من الأعمال الجاهزة ..عايزين أعمال تفصيل .إزاي وبالتفصيل الممل والخطواات اللازمة لعمل مثل تلك الأعمال السحرية ربنا يجعله في ميزان حسناتك يوم القيامة والله كنت ببالي اليوم ..ولما خطرت ببالي لقيتك في المنتدى (القلوب عند بعضها)

أستاذي الكريم رؤوف قم بضغط الملف أولاً ببرنامج وينرار ثم رفعه بارك الله فيك على مجهودك الذي أحسبه سيكون رائعاً بإذن الله raouf.rar

أعني الخلية A3 مثلاً إذا كانت فارغة لا يتم الترحيل وهذا ما طبقته في المشاركة رقم 11

أخي الحبيب أبو يوسف يمكن معالجة تلك النقطة بسهولة بربط الكود بخلية محددة إذا كانت فارغة يتم الخروج من تنفيذ الكود ..

أخي الكريم أبو حنين إليك التعديل التالي (لم أفهم طلبك الأخير ..كيف لا تحتوي ورقة العمل غير على خلية واحدة ..حاول تربط النقطة بخلية محددة تكون فارغة) Sub TransferToSpecificSheet() Dim Cell As Range, T As String, LR As Long, LRT As Long Dim WS As Worksheet, Answer As Long Set WS = Sheets("1") LR = WS.Cells(35, 3).End(xlUp).Row T = WS.Range("A3").Value Application.ScreenUpdating = False If Not IsEmpty(WS.Range("A3")) Then Range("B6:G" & LR).Copy With Sheets(T) LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1 .Cells(LRT, 2).PasteSpecial xlPasteValues End With Answer = MsgBox("هل تريد أن تمسح البيانات في ورقة 1 أم لا؟", vbYesNo + vbQuestion) If Answer = vbYes Then Sheets("1").Activate Sheets("1").Range("A3,C6:C35,F6:G35").Select Selection.ClearContents Else: End If Else MsgBox "الخلية المحددة فارغة لذا لن يتم تنفيذ الكود": Exit Sub End If Application.CutCopyMode = False Application.ScreenUpdating = True End Sub تقبل تحياتي

تفضل أخي الكريم أبو عبد الملك الملف التالي تم إضافة السطر التالي .Cells(I, 18) = Application.WorksheetFunction.Sum(Range(.Cells(I, 5), .Cells(I, 7)), .Cells(I, 9), .Cells(I, 11)) تم تلوين عناوين الحقول التي يتم إدخالها بشكل يدوي للتمييز Quran School V5.rar

الأخ الكريم يرجى تحديد أفضل إجابة ليظهر الموضوع منتهي كما يرجى تغيير اسم الظهور للغة العربية تقبل تحياتي

أخي الكريم أبو عبد الملك إليك الملف التالي .. يكفي لهذا الموضوع هاتين النقطتين ..لا تنسى أن تحدد أفضل إجابة ليظهر الموضوع مجاب ومنتهي غداً إن شاء الله نلتقي ..يا ريت تتابع معي حجم الملف 102 كيلو بايت فقط ... ويا ريت أعرف كم نسبة الإنجاز في البرنامج إلى الآن ..كم حققت من نسبة إنجاز ؟ طممن قلبي (لسه باقي كتير !!!) Quran School V5.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 Dim X, Y 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) End With Application.ScreenUpdating = False With SH SH.Range("A2:E1000,I2:I1000").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, 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 Next I .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 تقبل تحياتي Quran School V5.rar

أخي الكريم أنا لا أفهم لغة الدائن والمدين راجع الملفات المرفقة من قبلكم وشوف النتائج وراجع الملف المرفق من قبلي وشوف النتائج ..النتائج واحدة (لا أفهم في المحاسبة ..!!)

يرجى تحديد أفضل إجابة أخي الغالي ليظهر الموضوع منتهي

نفس الملف أخي زوهير المقدم من الأخ أبو يوسف بارك الله فيكما

اعتقد النتائج صحيحة انظر للخلية H22 على سبيل المثال .. الظاهر لديك 5181 لأنك منسق الخلايا بهذا الشكل بينما لو نظرت إلى شريط المعادلة ستجد أن الرقم هو 5181.34715025907 شوف بياناتك أولاً

أخي الحبيب علاء المتحفر هلا أرفقت ملفاً للعمل عليه ..لعلنا نستطيع أن نجد حلاً تقبل تحياتي

أخي الكريم أنس دروبي يرجى تغيير اسم الظهور للغة العربية Sub SUMIFSUsingArrays() Dim A, X, Y, myName As String, Cell As Range, I As Long Dim WS As Worksheet, SH As Worksheet, Rng As Range Set WS = Sheets("دفتر اليومية"): Set SH = Sheets("ميزان المراجعة") Set Rng = SH.Range("B8:B" & SH.Cells(Rows.Count, 2).End(xlUp).Row) A = WS.Range("A5:K" & WS.Cells(Rows.Count, 1).End(xlUp).Row) Application.ScreenUpdating = False For Each Cell In Rng If Cell.Value <> 0 Then myName = Cell.Value X = 0: Y = 0 For I = 1 To UBound(A, 1) On Error Resume Next If A(I, 2) = myName Then If Not IsEmpty(A(I, 8)) Then X = X + A(I, 8) If Not IsEmpty(A(I, 9)) Then Y = Y + A(I, 9) End If Next I Cell.Offset(, 3) = X: Cell.Offset(, 4) = Y With SH.Range("C8:C" & SH.Cells(Rows.Count, 2).End(xlUp).Row) .Formula = "=IF(E8>F8,E8-F8,"""")" .Value = .Value End With With SH.Range("D8:D" & SH.Cells(Rows.Count, 2).End(xlUp).Row) .Formula = "=IF(F8>E8,F8-E8,"""")" .Value = .Value End With End If Next Cell Application.ScreenUpdating = True End Sub ميزان المراجعة بالكود.rar

الأخ الكريم أبو حنين جرب الكود التالي Sub TransferToSpecificSheet() Dim Cell As Range, T As String, LR As Long, LRT As Long Dim WS As Worksheet Set WS = Sheets("1") LR = WS.Cells(35, 3).End(xlUp).Row T = WS.Range("A3").Value Application.ScreenUpdating = False If Not IsEmpty(T) Then Range("B6:G" & LR).Copy With Sheets(T) LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1 .Cells(LRT, 2).PasteSpecial xlPasteValues End With End If Application.CutCopyMode = False Application.ScreenUpdating = True End Sub بقيت نقطة المسح فقط ..وأنا لدي بعض الأعمال إن شاء الله يساعدك أحد الأخوة بها

أبو حنين اسمح لي أن أقول أني لا أفهم طلبك بشكل وااااضح حيث أن التفصيل غير مفصل بشكل تفصيلي يسهل معه الفهم .. ما فهمت إلا النقطة الأولى أنك تريد الترحيل حسب قيمة الخلية A3 في ورقة العمل المسماة "1" ...لكن الخلايا التي سترحل ما هي الخلايا التي سترحل ؟ أين تريد ترحيلها بالضبط ؟ وهل الترحيل يمسح البيانات السابقة في أوراق العمل المرحل إليها أم أنه يضيف إليها ؟ والنطاقات المراد مسحها غير منطقية .!..؟؟؟ يرجى التوضيح وبأسلوب مبسط يفهمه الجميع نسيت أقولك يا ريت لما تحب تدرج كود يوضع بين أقواس الكود ليظهر بشكل مناااااااااسب

أخي الحبيب مختار دايما سباق يا غالي جزيت خيراً على الموضوع الرائع اللي مطلع عيني م الصبح موضوعك شغلني بس مش من منظور مسح المحتويات كهدف ..ودا حاولت أوضحه هناك .. الفكرة اللي شغلتني إزاي نخلي مجموعة النطاقات مستثناة من العمل عليها ..كفكرة عامة بس بصراحة موضوعك روعة سؤال ممكن أعرف الفرق بين الكود في المشاركة الأولى والمشاركة رقم 6 ؟؟ مش تقريباً نفس الكود ولا أنا مش واخد بالي

أخي الكريم يرجى الآتي قبل أن أكمل معك تناول نقطة واحدة فقط في كل مرة حيث أنني أتشتت ولا أستطيع التركيز في أكثر من نقطة في نفس الوقت .. يكفي لهذا الموضوع النقاط الأربعة التي تم تناولها ولن أكمل في نفس الموضوع (طرح موضوع جديد لن يكون بالأمر المرهق ..) طرح موضوع جديد كمشاركة جديدة .. الرجاء احتمالي وصبرك علي .. إليك ما طلبت قمت بتجربة الملف .. ولا تنسى أن تحدد أفضل إجابة ألا وهي المشاركة الأخيرة التي تضمنت تناول الأربعة نقاط واستوفتهم إليك الملف المرفق Quran School V4.rar

أخي الفاضل ارفق مثال للتوضيح وللعمل عليه

أخي الحبيب يا ريت نقطة نقطة حتى نتمكن من العمل بشكل منضبط النقطة رقم 3 لم توضحها بالشكل اللائق .. لا يفرتض بي أن أعرف ما يدور بخلدك إلا بأمثلة .. العمود P فارغ ولا أعرف طبيعة البيانات فيه هل هي رقمية نصية ؟؟؟ يرجى وضع مثال للتوضيح ... لو كانت رقمية .. وكتب مثلاً 2 إذا فالدرجة تكون 5-2 أي 3 ..وضح كذلك بالنسبة لعمود الغياب يوضع حرف الغين أم يوضع رقم كل هذه الأمور قد تبدو بسيطة لك لكنها ذات أهمية في بناء الأكواد والبرنامج بشكل عام وأريد ألا أكرر موضوع التوضيح والتفصيل بارك الله فيك

أخي الكريم يرجى تغيير اسم الظهور للغة العربية إليك الكود التالي ..العمل على العمود E و F في ورقة 1 Sub SUMIFSUsingArrays() Dim A, X, Y, myName As String, Cell As Range, I As Long A = Sheets("Sheet1").Range("F1").CurrentRegion.Value Application.ScreenUpdating = False For Each Cell In Sheets("ورقة1").Range("B3:B17") myName = Cell.Value X = 0: Y = 0 For I = 2 To UBound(A, 1) If A(I, 3) = myName Then X = X + A(I, 1): Y = Y + A(I, 2) Next I Cell.Offset(, 3) = X: Cell.Offset(, 4) = Y Next Cell Application.ScreenUpdating = True End Sub تقبل تحياتي

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