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

47 دقائق مضت, safaalden said:

وربي عمله فوق الراقي والرائع ربي يحفظة ويبارك فيه

 

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

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

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

في الحقيقة توجد المئات من الموضوعات والأكواد المشروحة هنا وهناك ويوجد موضوع بعنوان "مكتبة الصرح زاخرة بالشرح" وفيها أكواد كثيرة وبشرح معظمها

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

ولكن بعد التجربة وجدت أن شرح الأكواد غير مفيد (من وجهة نظري الخاصة) حيث أن ما يأتي سهلاً يذهب سدى ، وما أقصده هو أنه على المتعلم أن يبذل جهذاً .. وأكرر أن يبذل جهداّ في تعلم الأكواد وذلك عن طريق استخدام مفتاح 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 صف للعمل عليهم وتجربة الأكواد ...