ياسر العربى

تصدق مش هو 

مهو احمد زي الحاج احمد

مهي نتيجة الدالة او قيمتها مباشر هي هي

تسلم ياريس

اخي الكريم احمد

هذا يحدث لانك تحفظ الملف بامتداد XLSX

غير امتداد الملف الى XLS   او  XLSM  أو  XLSB

وسيحفظ باذن الله

واليك موضوع لاخي ابو البراء لشرح بدايات التعامل مع ال VBA

https://www.officena.net/ib/topic/64472-بداية-الطريق-لإنقاذ-الغريق/

بصراحه انا ريحت دماغى وجبتلك دا

دالة معرفة

Function kh_Names(FullName As String, ParamArray iNdex1()) As String
Dim i As Integer
Dim kh_Split, MyArray, Ar
Dim Kh_String As String, Sn As String, Re As String
On Error GoTo Err_Kh_Names
    '======================================
    MyArray = Array("عبد ", "أبو ", "ابو ", "آل " _
    , " الله", " الدين", " الإسلام", " الاسلام", " الحق", " النصر", " العهد", " النور", " بالله")
    '======================================
    Sn = Application.WorksheetFunction.Trim(FullName)
    For Each Ar In MyArray
        Re = Replace(Ar, " ", "^")
        Sn = Replace(Sn, Ar, Re)
    Next
    '======================================
    kh_Split = Split(Sn, " ", , vbTextCompare)
    On Error Resume Next
    For i = 0 To UBound(iNdex1)
        Kh_String = Kh_String & " " & kh_Split(iNdex1(i) - 1)
    Next
    On Error GoTo 0
    Kh_String = Replace(Trim(Kh_String), "^", " ")
    kh_Names = Kh_String
    Exit Function
Err_Kh_Names:
     kh_Names = ""
End Function

وكتابة الدالة كما يلي

=kh_Names($A1;COLUMN()-1)

كما بالمرفق

دا كود ليك ياجميل من فترة وليك اكواد كتير خاصة بموضوع الاسماء المركبة

وربنا يسهل واعمل انا كود مختلف عنهم باذن الله 

تقبل تحياتي

excel.rar

اخي الغالي ابو البراء تسلم على لمساتك

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

ولكن بعد ردك ولفت الانتباه لها اتضح انه من الافضل ان يتم احتسابها ضمن الرسوب للفت النظر لها اثناء ملئ البيانات

Function ASEEL(X As Range, Y As Range, Z As Range)
    Dim D As String
    Application.Volatile
    For Each Rng In X
        If Rng < Cells(Y.Row, Rng.Column) Or Rng = "غ" Then
            D = " (" & Cells(Z.Row, Rng.Column).Text & ")" & D
        End If
    Next
    If D <> "" Then
        ASEEL = D
    Else
        ASEEL = "ناجح ومنقول"
    End If
End Function

مشكور على الاضافة

تقبل تحياتي

مشكور اخي الكريم محي الدين ابو البشر 

اليك كود اخر يفى بالغرض

Sub splitText()
    Dim splitVals As Variant
    Dim totalVals As Long
    For Each xx In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
        splitVals = Split(xx.Value, " ")
        totalVals = UBound(splitVals)
        Range(Cells(xx.Row, xx.Column + 1), Cells(xx.Row, xx.Column + 1 + totalVals)).Value = splitVals
    Next
End Sub

excel.rar

اخي الكريم حاتم الملف فعلا حجمه كبير ولم استطيع تحميله الان

واذا كان الملف كما ذكرت البيانات به كبيرة بهذا الحجم فمن الطبيعي وجود بطئ في الملف 

لان الاكسيل في المقام الاول ليس بقاعدة بيانات بل يعتمد على حساب وتحليل البيانات المدخلة

ومن الواضح انك تستخدم المعادلات في كل الملف لان الملف XLSX

اذا كنت تريد تسريع الملف نوعا ما فعليك بالاستغناء عن بعض التنسيقات الشرطية او التنسيقات الغير مرغوب بها

ولا تسحب المعادلات الى نطاق كبير لن تصله له بمعنى ان نسحب معادلاتنا على نطاق يغطى اقصى حد للبيانات

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

وحاول تغير امتداد الملف الى XLSB

حتى نطلع على الملف

مرحبا بك اخي الكريم احمد في منتدى اوفيسنا

جرب  الكود دا

Sub TEST()
    Range("B1:D" & Range("B1:D1").End(xlDown).Row).ClearContents
    Columns("A:A").TextToColumns Destination:=Range("B1"), DataType:=xlFixedWidth, _
                                 FieldInfo:=Array(Array(0, 1), Array(4, 1), Array(9, 1)), TrailingMinusNumbers:= _
                                 True
End Sub

excel.rar

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

وتم تعديل الدالة لتكون بها ثلاث نطاقات اول نطاق بالدالة هو نطاق درجات الطالب والنطاق الثاني للدرجة الصغرى والثالث لاسماء المواد

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

وان شاء الله نجد له حل

تقبل تحياتي

اسماء المواد الراسب فيها دالة معرفة.rar

6 ساعات مضت, مختار حسين محمود said:

الله  الله  عليك يا ابو العربى

المصطبة فيها شغل جامد اهوه   ربنا يجعلها مصطبة خير دايما

مشكور استاذنا الغالي مختار         اللهم امين

جزاك الله كل خير

تفبل تحياتي

بارك الله فيك اخي ياسر ابو البراء

نشاطكم هو الملحوظ دائما وما نحن الا ومضة في اعمالكم ومساعداتكم

جزيت خيرا 

تقبل تحياتي

بسم الله الرحمن الرحيم
 

Sub YasserFIFO()
    Dim z As Byte
    Application.ScreenUpdating = False
    Range("K6:K23").ClearContents
    Range("D6:E23").Copy Range("R1")
    Range("r1:s18").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
    Range("G6:G23").Copy Range("T1")
    z = 1
    For Each x In Range("g6:g23")
        If x.Value <> "" Then
            If x.Value <= Cells(z, 18) Then
                Cells(x.Row, 11) = Cells(z, 19) * x.Value
                Cells(z, 18) = Cells(z, 18) - x.Value
            ElseIf x.Value > Cells(z, 18) Then
3               Cells(x.Row, 11) = Cells(x.Row, 11) + (Cells(z, 18) * Cells(z, 19))
                x.Value = x.Value - Cells(z, 18)
                Cells(z, 18) = 0
                For z = 1 To 20
                    If Cells(z, 18) = 0 Then GoTo 1
                    If Cells(z, 18) >= x.Value Then GoTo 2
                    If Cells(z, 18) < x.Value Then GoTo 3
1               Next z
2               Cells(x.Row, 11) = Cells(x.Row, 11) + (Cells(z, 19) * x.Value)
                Cells(z, 18) = Cells(z, 18) - x.Value
            End If
        End If
    Next
    Range("T1:T18").Copy Range("G6:G23")
    Range("R1:T18").Clear
    Range("a1").Activate
    Application.ScreenUpdating = True
End Sub

FiFo_2.rar

بسم الله الرحمن الرحيم

للتسهيل في استخراج مواد الرسوب للطلبة تم عمل هذه الدالة لاستخراج المواد الراسب فيها او متغيب

يشترط وجود صف الدرجة العظمى ودرجة النجاح

نضع هذا الكود في موديول

Function ASEEL(x As Range)
    Dim D As String
    For Each Rng In x
        If Rng = "" Then GoTo 1
        If Rng < Cells(5, Rng.Column) Or Rng = "غ" Then
            D = " (" & Cells(3, Rng.Column).Text & ")" & D
        End If
1   Next
    If D <> "" Then
        ASEEL = D
    Else
        ASEEL = "ناجح ومنقول"
    End If
End Function

ونضع هذه الدالة في الملاحظات داخل الكشف ونسحبها نزولا  كما موضح بالمرفق

=ASEEL(D6:J6)

وشكرا

دالة معرفة لاستخراج مواد الرسوب.rar

مرحبا بك اخي احمد في منتدى اوفيسنا 

كلنا فخورين بهذا الصرح العلمي الرائع وكلنا طلاب علم في هذه الجامعه العريقه

ومما لا شك فيه هو ان الجميع مستفيد هنا

ونشكر جهود كل من ساعد في بناء هذا الصرح العلمي

تقبل تحياتي

مشكور اخي الكريم على حيدر   على الكود الرائع

جزيت خيرا

تقبل تحياتي

الجمع باكثر من شرط في معادله واحدة هو جمع عمود واحد فقط بأكثر من شرط

بالدالة SUMIFS

جرب اجمع الاتنين

=SUMIF(B:B;F2;C:C)+SUMIF(B:B;F2;D:D)

هل تقصد هكذا 

Sub CopyRows()
    Dim LR As Long, I As Long, X As Long
    LR = Sheets("Sheet1").Cells(Rows.Count, "g").End(xlUp).Row
    X = 5
    Application.ScreenUpdating = False
        Sheets("Sheet2").Rows("5:1000").ClearContents
        For I = 6 To LR
            If Cells(I, "g").Value < 90 And Cells(I, "g").Value >= 1 Then Rows(I).Copy Sheets("Sheet2").Range("A" & X): X = X + 1
        Next I
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

اولا مرحبا بك اخي الكريم مصطفى في منتدى اوفيسنا

ثانيا يرجى قراءة توجيهات  المنتدى لتسهيل التعامل داخل المنتدى

وكما يرجى ارفاق مثال بسيط للمطلوب

على ما اظن الدالة التى تقصدها هي SUMIF أو SUMIFS

جمع بشرط او اكثر

المثال هيوضح اكتر

تقبل تحياتي

ياخسارة كنت عاوز اكد موضوعك ولكن حاولت فك حماية ملف اكسيل امتداد XLS    و  XLSX 

ولكن يعطيني لا يستطيع فك تشفير هذا الملف

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

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

مشكور على المحاولة

تقبل تحياتي

فكرة جميلة استاذنا الكريم مختار مشكور

اخي عبد العزيز منور يامعلم

لو السهم مش  مظبوط على الخليج حرك الصورة حتى يتطابق السهم على الخليج ثم غير المناطق وشوف هل في اختلاف ولا لا

وشكرا

هههههه

الحمد لله

ودا شرف لي ان تكون افكارى تشابه افكارك اخي الكريم سليم

تقبل تحياتي

اولا معذرة اخي سليم لم ارى اجابتك

ثانيا تفضل اخي احمد المعادلة التالية

=IF(SUBTOTAL(3;$B$3:$B$12)=COUNTA($B$3:$B$12);"";SUBTOTAL(109;$B$3:$B$12))

اخي الكريم احمد

ضع هذه المعادلة مكان الخلية الصفراء

=SUBTOTAL(109;$B$3:$B$12)

لا يمكن اخي الكريم ابو تامر

XLSX  غير مخصص لحفظ الاكواد
المخصص والشائع الاستخدام لحفظ وحدات الماكرو عموما هم  Xls   Xlsm   Xlsb

مشكور استاذنا الكريم ا محمد طاهر

ولاثراء الموضوع بالكود والغاء علامة  $ وتحويل القيم الى رقمية لاجراء العمليات الحسابية على المخرجات بكل سهولة

Sub splitText()
    Dim splitVals As Variant
    Dim totalVals As Long
    For Each xx In Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
        splitVals = Split(xx.Value, "$")
        totalVals = UBound(splitVals)
        Range(Cells(xx.Row, xx.Column + 1), Cells(xx.Row, xx.Column + 1 + totalVals)).Value = splitVals
    Next
    FIND
    ConvertTextNumberToNumber
End Sub
Sub ConvertTextNumberToNumber()
    On Error Resume Next
    For Each Y In Sheet1.UsedRange.SpecialCells(xlCellTypeConstants)
        If IsNumeric(Y) Then Y.Value = Val(Y.Value)
    Next
End Sub
Sub FIND()
  Range("D:D").Replace What:="–", Replacement:="", LookAt:=xlPart
End Sub

تقبل تحياتي

Split PT Prices around the world.rar