ياسر العربى

تصدق مش هو مهو احمد زي الحاج احمد مهي نتيجة الدالة او قيمتها مباشر هي هي تسلم ياريس

اخي الكريم احمد هذا يحدث لانك تحفظ الملف بامتداد 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

مشكور استاذنا الغالي مختار اللهم امين جزاك الله كل خير تفبل تحياتي

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

بسم الله الرحمن الرحيم طلب بعض الاخوة موضوع الوارد اولا صادر اولا (FIFO) قمنا بعمل مثال بالاكواد لحل هذه المشكلة المثال يعتمد على اعمدة مساعدة ويتم مسح البيانات منها بعد الانتهاء الكود المستخدم 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