نجوم المشاركات

شرف ليا انى اضيف موضوع وسط اساتذتى https://www.mediafire.com/file/pzr38qxqwg4e2a2/Ferry_Login_v1-_free.accdb/file Ferry Login v1free.accdb

تفضل اخي @محمد زيدان2024 تم تعديل الاكواد لتتناسب مع طلبك Option Compare Text Public Property Get f() As Worksheet: Set f = Worksheets("12 د بنون") End Property '================29/06/2024 by:MOHAMEED HICHAM www.officena.net "منتدى الاكسيل" ' '=========================================================================================== Sub TriTotal_Descending_Order() 'ترتيب تنازلي Dim a() Dim r As Range a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value Set r = f.Range("C11:J" & f.[C65000].End(xlUp).Row) ' تحديد نطاق معين 'a = [C11:J38].Value: Set r = [C11:J38] ' <<=======عمود المجموع======== Call Quick(a(), LBound(a), _ UBound(a), 7, False): r.Value2 = a End Sub '**********فرز سريع************* Sub Quick(a(), gauc, droi, Cnt, ordre) Total = a((gauc + droi) \ 2, Cnt) Rng = gauc: d = droi Do If ordre Then Do While a(Rng, Cnt) < Total: Rng = Rng + 1: Loop Do While Total < a(d, Cnt): d = d - 1: Loop Else Do While a(Rng, Cnt) > Total: Rng = Rng + 1: Loop Do While Total > a(d, Cnt): d = d - 1: Loop End If If Rng <= d Then For i = LBound(a, 2) To UBound(a, 2) temp = a(Rng, i): a(Rng, i) = a(d, i): a(d, i) = temp Next i Rng = Rng + 1: d = d - 1 End If Loop While Rng <= d If Rng < droi Then Call Quick(a, Rng, droi, Cnt, ordre) If gauc < d Then Call Quick(a, gauc, d, Cnt, ordre) End Sub '************************************ Sub Tri_Colmun_Name() 'ترتيب ابجدي Dim clé() As String, index() As Long, Rng As Range a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value Dim b(): Set Rng = f.[C11] ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2)) Set rCrit = CreateObject("System.Collections.Sortedlist") For i = LBound(a) To UBound(a) rCrit.Add a(i, 1) & i, i Next i For tmp = LBound(a) To UBound(a) For arr = LBound(a, 2) To UBound(a, 2) b(tmp, arr) = a(rCrit.GetByIndex(tmp - 1), arr) Next arr Next tmp Rng.Resize(UBound(b), UBound(b, 2)).Value2 = b End Sub '************************************* Sub Tri_Total_Colmun() 'ترتيب تصاعدي Dim clé() As String, index() As Long, Rng As Range a = f.Range("C11:J" & f.[C65000].End(xlUp).Row).Value Dim b(): Set Rng = f.[C11] ReDim b(LBound(a) To UBound(a), LBound(a, 2) To UBound(a, 2)) Set rCrit = CreateObject("System.Collections.Sortedlist") For i = LBound(a) To UBound(a) rCrit.Add a(i, 7) & i, i Next i For tmp = LBound(a) To UBound(a) For arr = LBound(a, 2) To UBound(a, 2) b(tmp, arr) = a(rCrit.GetByIndex(tmp - 1), arr) Next arr Next tmp Rng.Resize(UBound(b), UBound(b, 2)).Value2 = b End Sub فرز V3.xlsb

شكر وتقدير واحترام من اخيك

انت لم تنتبه انه لديك نفس قيمة المجموع للاسماء 🤔🤔🤔 فارس محمد عبد الرازق اسماعيل 676 عمار سيد عبد الرازق اسماعيل 676 الكود يقوم بتحديثها جرب تغيير الرقم وسوف تلاحظ الفرق

احسنت وبارك الله فيك ا/ محمد هشام

تمام اخي محمد

طلبك غير واضح بالنسبة لي ربما لم استطع استوعابه يمكنك شرح المطلوب بشكل اكثر وضوحا عند الاجابة على هده الاسئلة اخي @محمد زيدان2024 ادا قمنا بترتيب كل عمود على حدى هدا سياثر على صحة البيانات المجاورة من تاريخ الميلاد وحتى عمود السنة في حالة قمنا بفرز عمود الاسم ابجديا مع تحديد جميع البيانات هدا من شانه ان ياثر على ترتيب عمود المجموع وعند محاولة ترتيبه هو الاخر سيأثر على بياناتك سوف يصبح مجموع محمد مثلا يقابل اسم جرجس

حاولت البحث عن عبارة حي الشرطة لم اجدها في عمود القرية هل هده اللغة السندية

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

انت استاذ كبير أيها المشاكس بصراحه الملف ممتاز وشغل عالي ابدعت وتألقت فعلا

'In cell P4 =UNIQUE(FILTER(B5:B300,B5:B300<>"")) 'In cell Q4 =SORT(UNIQUE(FILTER(C5:C300,(C5:C300 <>"")*( B5:B300=I5),""))) 'In cell R4 =SORT(UNIQUE(FILTER(D5:D300,(D5:D300 <>"")*( B5:B300=I5)*( C5:C300=J5),""))) 'In cell S4 =SORT(UNIQUE(FILTER(E5:E300,(E5:E300 <>"")*( B5:B300=I5)*( C5:C300=J5)*( D5:D300=K5),""))) 'In cell T4 =SORT(UNIQUE(FILTER(F5:F300,(F5:F300 <>"")*( B5:B300=I5)*( C5:C300=J5)*( D5:D300=K5)*( E5:E300=L5),""))) Create drop-down lists Cells i5 =$P$4# / Cells j5 =$Q$4# / Cells k5 =$R$4# / Cells L5 =$S$4# / Cells M5 =$T$4# عمل قائمة منسدلة.xlsx

الاستاذين الفاضلين ماقصرتو والنعم منكم

تقدر تضيف اكتر من سنه بنفس الطريقه انا زودت لحضرتك سنتين وتقدر تزود اكتر من سنه بنفس الطريقه Private Sub x_AfterUpdate() If x1 <> 0 Then ' لا تفعل شيئًا إذا كانت x1 ليست صفرًا Else Select Case x Case "1446" x1 = Nz(DMax("[m]", "mm", "yy = '1446'") + 1, 4600001) Case "1447" x1 = Nz(DMax("[m]", "mm", "yy = '1447'") + 1, 4700001) Case "1448" x1 = Nz(DMax("[m]", "mm", "yy = '1448'") + 1, 4800001) Case "1449" x1 = Nz(DMax("[m]", "mm", "yy = '1449'") + 1, 4900001) ' يمكنك إضافة حالات أخرى للأعوام الأخرى بنفس الطريقة Case Else MsgBox "السنة غير مدعومة." End Select End If End Sub

اللهم امين معلشي والله انشغلت شويه بس البروفيسور شايب العملاق حلها

الاستاذين الفاضلين شايب و M.Abd Allah اجابتين راقيتين صاغتهما انامل من ذهب اللهم خضب تلك الانامل بحناء الجنه .

وعليكم السلام ورحمه الله وبركاته شوف كده دا اللي انت عايزه ولا لاء جلب قيمه1.accdb

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

شكرا جزيلا لحضرتك وكل عام وانتم بخير

إليك كود VBA بسيط يمكنك استخدامه لحفظ الصفحة الحالية كملف PDF في Excel 2007: Sub SaveAsPDF() Dim savePath As String ' اطلب من المستخدم تحديد مكان الحفظ savePath = Application.GetSaveAsFilename(FileFilter:="PDF Files (*.pdf), *.pdf") ' حفظ الصفحة كملف PDF If savePath <> "False" Then ActiveSheet.ExportAsFixedFormat Type:=0, Filename:=savePath, Quality:=1, IncludeDocProperties:=True, IgnorePrintAreas:=False End If End Sub يمكنك نسخ الكود أعلاه ولصقه في وحدة VBA في Excel 2007، ثم تشغيله لحفظ الصفحة الحالية كملف PDF. يرجى ملاحظة أن جودة الصورة المصدرة قد تكون أقل من ExportAsFixedFormat المتاحة في إصدارات أحدث من Excel.