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

الأخ الكريم d911 يرجى تغيير اسم الظهور للغة العربية كما يرجى الإطلاع على رابط التوجيهات لمعرفة كيفية التعامل مع المنتدى من هنا التوجيهات (ضروري وهام) إليك الكود التالي عله يفي بالغرض Sub FillTRUE() Dim Source As Worksheet, Target As Worksheet, Cell As Range Dim FoundColumn, FoundRow Set Source = Sheet1: Set Target = Sheet2 With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual End With For Each Cell In Source.Range("B2:B" & Source.Cells(Rows.Count, "B").End(xlUp).Row) FoundRow = Application.Match(Cell.Offset(, -1), Target.Columns(1), 0) FoundColumn = Application.Match(Cell, Target.Rows(1), 0) If IsNumeric(FoundColumn) And IsNumeric(FoundRow) Then Target.Cells(FoundRow, FoundColumn).Resize(, Cell.Offset(, 2).Value) = "TRUE" End If Next Cell With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic End With End Sub تقبل تحياتي

دا وارد مع الكود لو عملت كوبي للملف في بارتشن تاني غير البارتشن الموجود يعني لو الملف موجود على البارتشن C لو أخذت منه نسخة على البارتشن D أو أي بارتشن آخر سيقوم بنفس المطلوب غير السطر التالي With oFso.GetDrive(oFso.GetDriveName(Application.Path)) إلى السطر التالي With oFso.GetDrive(oFso.GetDriveName(ThisWorkbook.Path)) بكدا هيكون الملف مرتبط بالبارتشن اللي فيه المصنف أرجو أن يؤدي الغرض

بسيطة يا أخي طاهر ادخل على Excel Options ثم Advanced ثم في الناحية اليمنى في الأول هتلاقي الخيار ده After Pressing Enter,move selection وتحته قائمة منسدلة فيها المطلوب : تحت - يمين - فوق - شمال اختار اللي يعجبك Down - Right - Up - Left بس خلاص

أخي الكريم طاهر محمد يمكن عمل المطلوب عن طرق التحقق من الصحة حدد الخلايا المطلوب العمل عليها وروح للتبويب Data ثم الأمر Data Validation هيطلع لك نافذة (ممكن تفتحها تدخل نسمة هوا عشان تخفف حدة الحر شوية) ومن النافذة اختر من القائمة المنسدلة الأولى Text Length ودي بتتعامل مع طول النص ومن القائمة المنسدلة الثانية اختر Equal to زي ما طلبت لا أكثر ولا أقل دي تديك النتائج بالضبط وأخير في المستطيل الأخير الموجود اكتب طول النص 11 زي ما طلبت واضغط أوك حاول تكتب في الخلايا اللي حددتها وجرب وشوف اللي هيحصل

أخي الكريم أشرف يفضل دائماً لتجد المساعدة بشكل أفضل أن تطرح أي طلب جديد في موضوع مستقل ..أي لكل طلب موضوع أو بشكل آخر الموضوع لطلب واحد فقط عموماً يرجى الإطلاع على التوجيهات مرة أخرى لمعرفة مزيد من التفاصيل جرب الكود التالي عله يكون المطلوب (وإن كنت لا أحب العمل في نفس الموضوع لأكثر من طلب ..بس عشان خاطر عيونك هعديها المرة دي ) Sub TransferToSheet3() Dim Source As Worksheet, Target As Worksheet Dim LR As Long, I As Long, X As Long Dim SourceRange As Range, Found Set Source = Sheet1: Set Target = Sheet3 LR = Source.Cells(Rows.Count, 1).End(3).Row X = 5 Application.ScreenUpdating = False Target.Range("A5:B1000").ClearContents With Source For I = 4 To LR Found = Application.Match(.Cells(I, "G"), .Range("B4:B" & LR), 0) If IsNumeric(Found) And .Cells(I, "M") = "نعم" Then .Cells(I, "F").Resize(1, 2).Copy Target.Cells(X, "A").PasteSpecial xlPasteValues X = X + 1 End If Next I End With Source.Activate Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Done.", 64 End Sub

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

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

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

أخي الكريم عبد الله ممكن مزيد من التفصيل لتتضح الصورة .. في الملف المرفق يوجد مصنفين واحد باسم "كشف الايتام" والتاني باسم "استبانة يتيم" في مصنف "كشف الايتام" يوجد ورقتي عمل ... أيهما مصدر البيانات للاستبانة ؟ أمر آخر ما هو الشكل المتوقع للاستبانة .. يرجى وضع نموذج للمطلوب المتوقع ؟ أمر آخر .. هل تريد تصدير كل ID إلى ملف ورد منفصل أم إلى ملف إكسيل منفصل؟ مزيد من التوضيح أخي الحبيب

حاول ترفق ملف بمعادلتك الجديدة وتوضح المطلوب بمزيد من التفصيل يا ولد .. الحجاز

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

أخي الكريم أبو عبد الملك يبدو أنك نسيت المبدأ .. بدلاً من أن تقوم بالرفع للموضوع أكثر من مرة كان يمكنك طرح موضوع جديد بطلبك الجديد في غيابي وأعتقد ساعتها يمكن أن تجد استجابة أعتقد - وهذا مجرد رأي شخصي - أن الموضوعات الجديدة تستقطب الأعضاء أكثر من الموضوعات التي بها رد مسبق لأن العضو الذي يريد المساعدة عندما يجد رد مسبق يظن أن الموضوع قد انتهى أو أنه لكي يقدم المساعدة فعليه أن يتابع الموضوع من البداية وفي هذه الحالة وقته قد لا يسمح فيعزف عن الموضوع ، أو يترك المجال لمن قام بالرد أولاً أن يقوم بالرد مرة أخرى بدون تدخل منه عموماً معلش صدعتك إليك الكود التالي عله يكون المطلوب Sub FollowAll() Dim I As Long, lRow As Long Dim rngFound As Range Dim wsRecord As Worksheet, wsMonthly As Worksheet, SH As Worksheet Set wsRecord = Sheets("معلومات التسجيل"): Set wsMonthly = Sheets("مجمع النتائج الشهرية"): Set SH = Sheets("كشف متابعة") With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual End With With wsRecord For I = 2 To .Cells(Rows.Count, "A").End(xlUp).Row If Not IsEmpty(.Cells(I, "N")) Then If MsgBox("الطالب " & .Cells(I, "C") & " منقطع هل تود أن تطبع له كشف?", vbYesNo + vbMsgBoxRtlReading) = vbYes Then GoTo Continue Else: End If Else Continue: SH.Range("C1") = .Cells(I, "C") SH.Range("C4") = .Cells(I, "B") SH.Range("C5") = .Cells(I, "A") Set rngFound = wsMonthly.Columns("C:C").Find(What:=.Cells(I, "C"), searchorder:=xlByRows, searchdirection:=xlPrevious) If Not rngFound Is Nothing Then lRow = rngFound.Row If wsMonthly.Cells(lRow, "R") >= 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "N"): SH.Range("S4") = wsMonthly.Cells(lRow, "O") ElseIf wsMonthly.Cells(lRow, "R") < 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "L"): SH.Range("S4") = wsMonthly.Cells(lRow, "M") Else MsgBox "لا يوجد درجة للطالب " & .Cells(I, "C"), vbCritical End If End If SH.Range("C2").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$B$2:$B$6))" SH.Range("C3").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$D$2:$D$6))" SH.Range("C2:C3").Value = SH.Range("C2:C3").Value Call CalculateLinesOfRevision SH.PrintPreview End If Next I End With With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic End With End Sub Private Sub CalculateLinesOfRevision() Dim SH As Worksheet, wsMnhg As Worksheet Dim LRCur As Long, I As Long, II As Long, N As Long, Counter As Long, P As Long Dim rngA As Range, rngB As Range, rngC As Range, rngD As Range Dim X, Y, Z Set SH = Sheets("كشف متابعة"): Set wsMnhg = Sheets("المنهج") With wsMnhg 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) SH.Range("Q11:Q34").ClearContents X = ValueLookUp(rngB, SH.Cells(4, "R").Value, rngC, rngD, SH.Cells(4, "S").Value, rngA) If X <= 24 Then For I = 2 To X + 1 SH.Cells(N + 11, "Q") = .Cells(I, "B") & " " & .Cells(I, "C") & " - " & .Cells(I, "B") & " " & .Cells(I, "D") N = N + 1 Next I Else Y = Application.WorksheetFunction.Ceiling(X / 24, 1) For I = 2 To X + 1 Step Y SH.Cells(N + 11, "Q") = .Cells(I, "B") & " " & .Cells(I, "C") & " - " & .Cells(I + Y - 1, "B") & " " & .Cells(I + Y - 1, "D") N = N + 1 Counter = Counter + Y If Y >= X - I Then Exit For Next I If X - Counter > 0 Then SH.Cells(N + 11, "Q") = .Cells(I + Y, "B") & " " & .Cells(I + Y, "C") & " - " & .Cells(X + 1, "B") & " " & .Cells(X + 1, "D") End If SH.Range("O11:O34").ClearContents Z = X - 24 If Z > 0 Then SH.Range("O11:O34") = .Cells(Z, "B") & " " & .Cells(Z, "D") & " - " & SH.Range("R4") & " " & SH.Range("S4") SH.Range("M11:M34,I11:I34").ClearContents P = 1 For II = 11 To 34 SH.Range("M" & II) = .Cells(X + P, "B") & " " & .Cells(X + P, "C") & " - " & .Cells(X + P, "D") SH.Range("I" & II) = .Cells(X + P + 1, "B") & " " & .Cells(X + P + 1, "C") & " - " & .Cells(X + P + 1, "D") P = P + 1 Next II SH.Range("M11:M34").Copy SH.Range("K11") End With End Sub

إليك الملف المرفق .. xx1.rar

أخي الحبيب إبراهيم مشكور على المجهود الرائع ومتابعينك فخلي بالك متخليش الجهاز يتعطل تاني ..

بسم الله ما شاء الله كود رائع ومفيد جداً بارك الله فيك أخي جعفر ولا حرمنا الله منك واصل بلا فواااااااااااااااااااصل ..

أخي الكريم ولد الحجاز الموضوع أبسط مما تتخيل هديك مثال وإنت كمل يا جميل تعالى في الخلية D3 في أول معادلة وعدل المعادلة بهذا الشكل =IF(B3="","",DATEDIF(B3,C3,"y")) أضفت لك جزء بقول فيه لو الخلية B3 كانت فاضية مش مشغولة بأي بيانات ، يا عم الإكسيل خلي الناتج فاضي وإلا كمل الجزء التاني ، فلما تكون الخلية فاضية هيكون الخلية اللي فيها الناتج فاضية كمل بنفس الأسلوب ملحوظة هامة : إذا لم تعمل المعادلة معك قم بتغيير الفاصلة العادية بفاصلة منقوطة (أصلي مغير في إعدادات الويندوز لأني برتاح في الفاصلة العادية أكثر من الفاصلة المنقوطة) تقبل تحياتي

أخي الحبيب حسام عيسى بارك الله فيك على الرابط الرائع والمفيد أخي الغالي جعفر لكم يسعدني ويدخل السرور على قلبي أن أرى مشاركاتك فيما بيننا أخي الكريم أشرف النعاس افتح الملف انقر بالماوس على زر الأمر Test1 .. هيطلع لك عفريت (متخافش منه دا عفريت صاحبي وأنا عارفه) هتلاقي في العفريت زر أوك اضغط عليه وهتلاقي قدامك أسطر باللون الأحمر تعالى بعد كلمة Declare وأضف كلمة PtrSafe هتلاقي السطر اللي بالأحمر بقا بالأزرق اضغط F5 عشان تنفذ هيطلع لك العفريت تاني كرر نفس الخطوات .. أضف الكلمة PtrSafe بعد كلمة Declare إلى أن تنتهي من جميع الأسطر وتختفي الأسطر التي باللون الأحمر يا ريت بس متنسناش بدعوة .. تقبلوا تحياتي

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

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

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

أخي الكريم عمرو حسني إليك الكود التالي Private iGblGoldenTotal As Long Private iGblOutputRow As Long Private iGblMatchingTotalCount As Long Private Const nOutputHeaderROW = 2 Sub FindCombinationsAddingToGoldenTotal() Dim vElements As Variant Dim vresult As Variant Dim I As Long, T As Long Dim iLastIndex As Integer Dim sValue As String Sheets("Sheet1").Range("H3:Z" & Rows.Count).ClearContents iLastIndex = 0 ReDim vElements(1 To 1) iGblGoldenTotal = Range("D1").Value For T = 2 To Cells(Rows.Count, "B").End(xlUp).Row sValue = Range("B" & T).Value If IsNumeric(sValue) Then iLastIndex = iLastIndex + 1 ReDim Preserve vElements(iLastIndex) vElements(iLastIndex) = sValue End If Next T iGblOutputRow = nOutputHeaderROW iGblMatchingTotalCount = 0 For I = 1 To UBound(vElements) ReDim vresult(1 To I) Call CombinationsNP(vElements, I, vresult, 1, 1) Next I End Sub Sub CombinationsNP(ByVal vElements As Variant, ByVal P As Long, ByRef vresult As Variant, ByVal iElement As Integer, ByVal iIndex As Integer) Dim I As Long Dim II As Long Dim iSum As Long For I = iElement To UBound(vElements) vresult(iIndex) = vElements(I) If iIndex = P Then iSum = 0 For II = LBound(vresult) To UBound(vresult) iSum = iSum + vresult(II) Next II If iSum = iGblGoldenTotal Then iGblOutputRow = iGblOutputRow + 1 iGblMatchingTotalCount = iGblMatchingTotalCount + 1 Range("H" & iGblOutputRow).Value = "مج " & iGblMatchingTotalCount Range("I" & iGblOutputRow).Resize(, P) = vresult End If Else Call CombinationsNP(vElements, P, vresult, I + 1, iIndex + 1) End If Next I End Sub مرفق الملف فيه تطبيق الكود .. تقبل تحياتي Totals For All Combinations.rar

يعطيك العافية أخي الحبيب المتميز خالد الرشيدي جزيت خيراً على دعائك الطيب وشعورك الطيب تقبل وافر تقديري واحترامي

هلا فيك أخي عمار ما زلت في حالة مرض ولكن أحاول التغلب عليه .. جزيت خيراً أخي الغالي

أخي الكريم عمرو حسني كيف سيتم تلوين كل مجموعة خلايا بلون واحد وهناك تداخل في النتائج المتوقعة بشكل كبير ..؟؟ أقصد أن الطلب غير منطقي إذ أن الرقم الواحد قد يدخل في أكثر من احتمال ومن ثم سيكون هناك لبس شديد فيما يخص التلوين يمكن الاعتماد على الجزء الآخر الذي أشرت إليه مج1 ومج2 وهكذا ... ملحوظة : النتيجة 3 5 2 أليست هي نفس النتيجة للاحتمال 2 3 5 (أعتقد أنه لا داعي للتكرار طالما أن نفس الأرقام تؤدي نفس النتيجة) في انتظار الرد على الملاحظات التي أشرت إليها

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