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

بارك الله فيك أخي الكريم وجزيت خيراً على كلماتك الطيبة .. ولك بمثل ما دعوت لي وزيادة

كان الله في عونك أخي العزيز .. وأقولك : ازعج كما تشاء فنحن سنكون في انتظار إزعاجك على الدوااااااااااااام .. فإزعاجك يسعدنا

بارك الله فيكم إخواني الكرام وجزيتم خيراً لحرصكم على تعلم العلم والاستفادة مما يقدم في الحقيقة توجد المئات من الموضوعات والأكواد المشروحة هنا وهناك ويوجد موضوع بعنوان "مكتبة الصرح زاخرة بالشرح" وفيها أكواد كثيرة وبشرح معظمها ويوجد حلقات "افتح الباب وادخل لعالم البرمجة" والتي تعطيك فكرة كبيرة عن الأساسيات والبدايات .. ولكن بعد التجربة وجدت أن شرح الأكواد غير مفيد (من وجهة نظري الخاصة) حيث أن ما يأتي سهلاً يذهب سدى ، وما أقصده هو أنه على المتعلم أن يبذل جهذاً .. وأكرر أن يبذل جهداّ في تعلم الأكواد وذلك عن طريق استخدام مفتاح F8 ليتمكن من تنفيذ الكود سطر بسطر ويرى ما يتم تنفيذه ويستفيد ، وإذا تعثر في سطر ما يسأل عنه .. فالفكرة في أن يجتهد في فهم الكود بنفسه فذلك وعن تجربة أفضل بكثير من تقديم شروحات جاهزة .. وفي النهاية أسأل الله أن يوفقنا جميعاً لما فيه الخير والصلاح في الدنيا والآخرة تقبلوا وافر تقديري واحترامي

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

وجزيت خيراً بمثل ما دعوت لي أخي أبو يحيى ..جرب الكود مرة أخرى بعد التعديل

وعليكم السلام ورحمة الله وبركاته جرب الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 Or Target.Column = 1 Then Range("c" & Target.Row) = Range("a" & Target.Row).Value * Range("b" & Target.Row).Value Else If Target.Column = 3 And Range("a" & Target.Row).Value <> "" And Range("a" & Target.Row).Value <> 0 Then If Range("b" & Target.Row) <> Range("c" & Target.Row).Value / Range("a" & Target.Row).Value Then Range("b" & Target.Row) = Range("c" & Target.Row).Value / Range("a" & Target.Row).Value End If End If End If End Sub

وجزيت خيراً بمثل ما دعوت لي أخي الكريم والحمد لله الذي بنعمته تتم الصالحات

بارك الله فيك أخي الكريم وجزيت خيراً بمثل ما دعوت لي المشكلة ليست في إرفاق الملف من قبلي بل المشكلة من قبلك حيث لا أدري بالضبط المقصود من موضوعك لذا فالأفضل إرفاق ملف .. بالنسبة للكود الذي أرفقته ... يفترض وجود ورقتي عمل Sheet1 و Sheet2 ... وفي ورقة العمل Sheet1 في العمود الأول ضع أرقام بشكل عشوائي في النطاق A1:A23 مثلاً ثم ضع الكود في موديول عادي ونفذ الكود وستجد النتائج بورقة العمل الثانية Sheet2

غير السطر الأخير t.Range("B14").Resize(6, 4).Value = s.Range("O" & r).Resize(6, 4).Value لاحظ التغيير بنفسك (حرف واحد)

ضع المرفق في الوضع الجديد للبيانات لتعديل الكود لك ..

عند نسخ الكود اجعل اتجاه الكتابة باللغة العربية ليتم النسخ بشكل صحيح . حيث يظهر في الصورة الخاصة بك الحروف العربية برموز غريبة

وعليكم السلام ورحمة الله Sub SUM_Each_Five_Cells() Dim ws As Worksheet Dim sh As Worksheet Dim ct As Long Dim nr As Long Set ws = Sheets("Sheet1") Set sh = Sheets("Sheet2") For ct = 1 To ws.Cells(Rows.Count, 1).End(xlUp).Row Step 5 nr = nr + 1 sh.Range("A" & nr).Value = Application.WorksheetFunction.Sum(ws.Range("A" & ct).Resize(5)) Next ct MsgBox "Done...", 64 End Sub

شاهد الحلقة التالية فيها شرح الأبجدة أو الترتيب لعله يفيدك

لم أفهم مقصدك أخي سليم .. عملية الحساب ليست Manual بل Automatic وما قدمته أعتقد حسب ما فهمت هو الصحيح للمطلوب ولكني لا أدري المشكلة لدى الأخ يوسف .. أو أنه ربما لا يستطيع وضع المعادلة الخاصة بك أو أنه عليه استبدال الفاصلة العادية بفاصلة منقوطة لكي تعمل عنده أو ربما نسي أن يضغط على Ctrl + Shift + Enter

إذا كنت لا تريد المسح قم بإزالة هذا السطر فقط sh.Range("A8:" & str & lr + 7).Clear أما إذا كان المطلوب غير ذلك فيرجى إرفاق ملف موضحاً فيه شكل النتائج المتوقعة

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

في b5 =IFERROR(INDEX(E5:J5,MATCH($B$2,$E$4:$J$4,0)),"")

وجزيت خيراً أخي الكريم بمثل ما دعوت لي وزيادة تقبل تحياتي

وعليكم السلام أخي الكريم محمد المهندس في الحقيقة بحثت عن حل بالمعادلات كبديل حيث أن الدالة SUMIF لا تعمل والملف مغلق .. وجربت SUMPRODUCT وجربت الدالة SUM ومعها IF في معادلة صفيف لعلها تؤدي بالغرض .. ورغم اختلاف المعادلات النتائج واحدة وصحيحة فقط إذا كان الملف مفتوح .. ولا يوجد أمامي سوى حل واحد لك وهو العمل بالأكواد .. حيث كود بسيط يمكن أن يحل المشكلة ، حيث يقوم الكود بدون أن تشعر بفتح الملف المغلق وإدراج المعادلات والحصول على القيم فقط للتخلص من المعادلات ثم إغلاق الملف .. كل هذا سيكون بضغطة زر واحدة فقط ، ولا أرجح أن يكون مع كل تغيير في الملف لأن الكود يقوم بفتح ملف آخر وإغلاقه وهذا قد يسبب بطء إذا تكرر في حدث تغير ورقة العمل .. بالتالي من وجهة نظري (ولعله توجد حلول أخرى والله أعلم) الأفضل هو اختيار الصرف المطلوب في العمود بالكامل وتنفيذ الكود مرة واحدة للحصول على النتائج فقط .. الكود مرفق به التعليقات لعلها تفيدك في فهم الكود لتستطيع التعديل عليه إذا أحببت في أي وقت Sub Test() Dim wb As Workbook 'إلغاء تحديث الشاشة لتسريع الكود Application.ScreenUpdating = False 'فتح المصنف الخاص بالمخزن للحصول على النتائج المطلوبة Set wb = Workbooks.Open(ThisWorkbook.Path & "\مصنف المخزن.xlsx") 'وضع المعادلات في النطاق في العمود الأول ثم الحصول على القيم فقط With ThisWorkbook.Sheets(1) With .Range("A3:A" & .Cells(Rows.Count, 1).End(xlUp).Row) .Formula = "=SUMIF('مصنف المخزن.xlsx'!الجدول1[النوع],[الصرف],'مصنف المخزن.xlsx'!الجدول1[المبلغ])" .Value = .Value End With End With 'إغلاق المصنف الخاص بالمخزن بدون حفظ التغييرات wb.Close False 'إعادة تفعيل خاصية تحديث الشاشة Application.ScreenUpdating = True End Sub

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

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

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

Private Sub UserForm_Activate() Dim i As Long For i = 17 To 32 Me.Controls("Label" & i) = Range("C" & i - 14) Next i For i = 37 To 42 Me.Controls("Label" & i) = Range("D" & i - 34) Next i End Sub

أخي الكريم .. إليك الكود التالي .. لا حاجة للاحتفاظ بالمعادلات في ورقة الهدف (النتائج) .. حيث وضعت لك دوال معرفة تقوم بنفس المهمة .. وتوفر عليك عناء كتابة وضبط المعادلات .. أدرج موديول جديد .. ثم ضع الكود التالي وجرب الكود وأخبرنا بالنتائج Option Explicit Sub TransferDataUsingArrays() Const startDate As Date = #10/1/2017# Dim ws As Worksheet Dim sh As Worksheet Dim arr As Variant Dim temp As Variant Dim birthDate As Date Dim i As Long Dim j As Long Dim p As Long Set ws = Sheets("بيانات الطلاب") Set sh = Sheets("سجل 41 مستجدين") arr = ws.Range("B17:T" & ws.Range("C" & Rows.Count).End(xlUp).Row).Value ReDim temp(1 To UBound(arr, 1), 1 To 18) For i = 1 To UBound(arr, 1) If arr(i, 5) = "مستجد" Or arr(i, 5) = "مستجدة" Then p = p + 1 For j = 1 To 18 temp(p, j) = arr(i, Choose(j, 1, 2, 7, 8, 9, 10, 7, 8, 9, 13, 4, 14, 15, 16, 2, 11, 12, 17)) Next j temp(p, 1) = p On Error Resume Next birthDate = CDate(temp(p, 3) & "/" & temp(p, 4) & "/" & temp(p, 5)) temp(p, 7) = CalculateAge(birthDate, startDate, "d") temp(p, 8) = CalculateAge(birthDate, startDate, "m") temp(p, 9) = CalculateAge(birthDate, startDate, "y") On Error GoTo 0 temp(p, 15) = KhFatherName(CStr(temp(p, 2))) End If Next i If p > 0 Then With sh.Range("B8") .Resize(1000, UBound(temp, 2)).ClearContents .Resize(p, UBound(temp, 2)).Value = temp End With End If End Sub Function KhFatherName(ByVal Name As String) As String Dim khString As String Dim searchChar As String Dim khMid As String Dim khRep As String Dim khMyNo As Integer On Error GoTo Err_KhFatherName If IsEmpty(Name) Then GoTo Err_KhFatherName khString = KhFatherReplace(Trim(Name)) & " " searchChar = " " khMyNo = InStr(1, khString, searchChar, 1) khMid = Trim(Mid(khString, khMyNo, Len(khString))) khRep = Replace(khMid, "_", " ") KhFatherName = khRep Exit Function Err_KhFatherName: KhFatherName = "" End Function Private Function KhFatherReplace(ByVal Kh_Sub As String) As String Dim myArray As Variant Dim ar As Variant Dim sn As String Dim re As String myArray = Array("عبد ", "أبو ", "ابو ", "آل ", " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله", " الزهراء") sn = Kh_Sub For Each ar In myArray re = Replace(ar, " ", "_") sn = Replace(sn, ar, re) Next ar KhFatherReplace = sn End Function Function CalculateAge(birth As Variant, start As Variant, str As String) Dim y As Long Dim m As Long Dim d As Long If Not IsDate(birth) Or Not IsDate(start) Then GoTo Skipper m = DateDiff("m", birth, start) d = DateDiff("d", DateAdd("m", m, birth), start) If d < 0 Then m = m - 1 d = DateDiff("d", DateAdd("m", m, birth), start) End If y = m \ 12 m = m Mod 12 Select Case str Case "d" CalculateAge = d Case "m" CalculateAge = m Case "y" CalculateAge = y End Select Exit Function Skipper: CalculateAge = "" End Function

أخي الكريم عند إرفاق ملف يراعى أن توجد بعض البيانات للعمل عليها وتجربة الأكواد قمت بتحميل الملف ولم أجد بيانات في ورقة العمل "بيانات الطلاب" ضع بعض البيانات للعمل عليها بحيث تكون معبرة عن الملف الأصلي ولا تضع الكثير من البيانات .. يكفي 20 صف للعمل عليهم وتجربة الأكواد ...