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

الكود Sub CustomSort() 'Excel VBA to Sort data in a custom list Dim r As Range Dim rng As Range Set r = Sheets("Target").Range("A6", Range("L" & Rows.Count).End(xlUp)) Set rng = Sheets("Target").Range("F1:F4") On Error Resume Next Application.AddCustomList rng r.Sort key1:=[L6], order1:=1, ordercustom:=Application.CustomListCount + 1, _ key2:=[J6], order2:=2, Header:=1 Application.DeleteCustomList Application.CustomListCount End Sub

كاسم المستلم مثلا او المستلم + المشروع معا لم أر المستلم ولا المشروع في الجدول فهل المستلم هو المستفيد والمشروع هو الموقع ام بالعكس جرب هذا الملف (صفحة One For_All ) الملف مرفق Option Explicit Dim DC As Object Dim DD As Object Dim D_Sh As Object Dim O As Worksheet Dim sh As Worksheet Dim i, Max_ro%, m% '++++++++++++++++++++++++++++++ Private Sub Worksheet_Activate() data_val End Sub '++++++++++++++++++++++++++ Sub MY_choose() Select Case Sheets("One For_All").Range("G2") Case "E": Filter_Only_E Case "D": Filter_Only_D Case "D+E": Filter_C_And_D Case Else: Exit Sub End Select End Sub '++++++++++++++++++++ Sub data_val() Set O = Sheets("One For_All") Set DC = CreateObject("Scripting.Dictionary") Set DD = CreateObject("Scripting.Dictionary") Max_ro = Sheets("Payments").Cells(Rows.Count, 2).End(3).Row For i = 2 To Max_ro DC(Sheets("Payments").Cells(i, "C").Value) = vbNullString DD(Sheets("Payments").Cells(i, "D").Value) = vbNullString Next With O.Range("D2").Validation .Delete .Add 3, Formula1:=Join(DC.keys, ",") End With With O.Range("E2").Validation .Delete .Add 3, Formula1:=Join(DD.keys, ",") End With End Sub '+++++++++++++++++++++++++++ Sub Filter_Only_E() Set O = Sheets("One For_All") If O.Range("C4").CurrentRegion.Rows.Count > 1 Then O.Range("C4").CurrentRegion.Offset(1). _ Resize(O.Range("C4").CurrentRegion. _ Rows.Count - 1).Clear End If Max_ro = Sheets("Payments").Cells(Rows.Count, 2).End(3).Row m = 5 If O.Range("E2") = vbNullString Then Exit Sub For i = 2 To Max_ro If Sheets("Payments").Cells(i, "D") = O.Range("E2") Then O.Cells(m, 3) = m - 4 O.Cells(m, 4).Resize(, 5).Value = _ Sheets("Payments").Cells(i, 2).Resize(, 5).Value m = m + 1 End If Next If O.Range("C4").CurrentRegion.Rows.Count > 1 Then With O.Range("C4").CurrentRegion.Offset(1). _ Resize(O.Range("C4").CurrentRegion.Rows.Count - 1) .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 35 .InsertIndent 1 End With End If End Sub '+++++++++++++++++++++++++++++++++++ Sub Filter_Only_D() Set O = Sheets("One For_All") If O.Range("C4").CurrentRegion.Rows.Count > 1 Then O.Range("C4").CurrentRegion.Offset(1). _ Resize(O.Range("C4").CurrentRegion. _ Rows.Count - 1).Clear End If Max_ro = Sheets("Payments").Cells(Rows.Count, 2).End(3).Row m = 5 If O.Range("D2") = vbNullString Then Exit Sub For i = 2 To Max_ro If Sheets("Payments").Cells(i, "C") = O.Range("D2") Then O.Cells(m, 3) = m - 4 O.Cells(m, 4).Resize(, 5).Value = _ Sheets("Payments").Cells(i, 2).Resize(, 5).Value m = m + 1 End If Next If O.Range("C4").CurrentRegion.Rows.Count > 1 Then With O.Range("C4").CurrentRegion.Offset(1). _ Resize(O.Range("C4").CurrentRegion.Rows.Count - 1) .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 35 .InsertIndent 1 End With End If End Sub '++++++++++++++++++++ Sub Filter_C_And_D() Set O = Sheets("One For_All") If O.Range("C4").CurrentRegion.Rows.Count > 1 Then O.Range("C4").CurrentRegion.Offset(1). _ Resize(O.Range("C4").CurrentRegion. _ Rows.Count - 1).Clear End If Max_ro = Sheets("Payments").Cells(Rows.Count, 2).End(3).Row m = 5 If O.Range("D2") = vbNullString Or _ O.Range("E2") = vbNullString Then Exit Sub For i = 2 To Max_ro If Sheets("Payments").Cells(i, "C") = O.Range("D2") And _ Sheets("Payments").Cells(i, "D") = O.Range("E2") Then O.Cells(m, 3) = m - 4 O.Cells(m, 4).Resize(, 5).Value = _ Sheets("Payments").Cells(i, 2).Resize(, 5).Value m = m + 1 End If Next If O.Range("C4").CurrentRegion.Rows.Count > 1 Then With O.Range("C4").CurrentRegion.Offset(1). _ Resize(O.Range("C4").CurrentRegion.Rows.Count - 1) .Borders.LineStyle = 1 .Font.Size = 14 .Font.Bold = True .Interior.ColorIndex = 35 .InsertIndent 1 End With End If End Sub Hisabat_Super.xlsm

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

السلام عليكم ورحمة الله وبركاته الدرس الثالث من كورس احتراف الدوال والمعادلات في الاكسل واكتشاف اخطاء المعادلة وحلها نتمنى أن يستفاد الجميع بها ان شاء الله لاتنسونا من دعائكم test.xlsx

السلام عليكم ورحمة الله جرب هذا الكود Sub GetName() Dim ws As Worksheet, Arr As Variant Dim LR As Long, i As Long Dim j As Long, x As Long Application.ScreenUpdating = False Set ws = Sheets("ورقة2") LR = ws.Range("A" & Rows.Count).End(3).Row Arr = ws.Range("A13:AA" & LR).Value x = 3 Do While x <= 27 For i = 1 To UBound(Arr, 1) For j = 1 To UBound(Arr, 2) If ws.Cells(1, x) = Arr(i, j) Then ws.Cells(2, x) = Arr(i, 1) End If Next Next x = x + 1 Loop Application.ScreenUpdating = True End Sub

الله يرضى عنك وعن والديك دائما تبدع وتفاجئنا باعمال رائعة مثلك استاذ سليم يوجد لى طلب اخر شيت توزيع المتوسط ممكن المساعدة فيه

السلام عليكم ورحمة الله وبركاته اظهار اسم المنتج والتاريخ .. في جدول الكمية .. باللون الاصفر .. ان شاء الله ان يكون هو المطلوب .. Production Date.xlsx

شاهد هذا الفيديو الدقيقة 10 : 2 https://edu.gcfglobal.org/en/excel2013/sorting-data/1/

السلام عليكم ورحمة الله وبركاته مبارك لكما أخويّ الكريمين خيماوى كووول و عبدالله الصارى انضمامكما لعائلة الخبراء الكريمة متمنياً لكما النجاح الباهر والمستقبل الزاهر 👍🌺🙂

نعم هذا هو المطلوب جزاك الله خير الثواب

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

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

ألف مبروك تستحقانها عن جدارة

الف مبروك لاساتذتنا الكرام ودائما فى تقدم ان شاء الله

الف الف مبروك لهما ومسيرة موفقة باذن الله

جرب الكود =DCount("*";"Employee";"[dept]='" & [Dept] & "'" & "and [Status] Is Null") Employees.accdb

أشكر لك اهتمامك وتواصلك الدائم بارك الله فيك أخي الحبيب

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

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

وعليكم السلام 🙂 انزل البرنامج من رابط هذا المرفق ، واصلح برنامجك جعفر

شكرا لإهتمامك .. هل لابد وجود برنامج pdf الأساسي.. لان ظهرت هذه الرسالة ..الله يعافيك

المشكلة كانت هنا (الصورة) النطاق من E3 الى Z3 لا يجب ان بكون فارغاً (للمحافظة على تنسيق الحدول) ضع فيه أي شيء (مثلاً انا وصعت الاعداد من 1 الى 22 بتنسيق احفاء) الملف مرفق من جدبد Moustsfa_New.xlsm

جرب هذا الماكرو لعله يكون المطلوب (فقط اصغط الزر Run ) Option Explicit Sub Text_to_date() Dim st, i%, m%, k%, ro Dim arr() Dim My_dat As Date Dim stg ro = Cells(Rows.Count, 1).End(3).Row If ro < 2 Then Exit Sub Range("C2:C" & ro).ClearContents For i = 2 To ro st = Split(Cells(i, 1)) For k = LBound(st) To UBound(st) If st(k) <> "" Then ReDim Preserve arr(m) arr(m) = st(k) m = m + 1 End If Next k On Error Resume Next stg = """" & arr(2) * 1 & " " & arr(0) & " " & arr(1) * 1 & """" If Err.Number > 0 Then GoTo Next_I If IsDate(Evaluate(stg)) Then My_dat = Evaluate(stg) Cells(i, 3) = My_dat End If Next_I: Erase arr: m = 0: On Error GoTo 0 Next i End Sub الملف مرفق Text_to dat.xlsm

مرفق ملف ... أتمنى ان يكون هو المطلوب كما نرجو من الزملاء بالمنتدى التعليق والاضافة حتى يكون الملف يشمل جميع النقاط taxes on salary 2020.xlsx