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

السلام عليكم ورحمة الله تعالى وبركاته • هدية اليوم هى منتقى التواريخ تم الانتهاء من البرمجة والتطوير بالتعاون مع الاستاذ @Moosak ابداع وروعة وجمال تنسيق التصميم قام به اخى الحبيب و استاذى الجليل الاستاذ @Moosak كل الشكر والتقدير والامتنان على تعبه وحرصه على ان يخرج التطبيق بهذه الافكار الى النور فى ابهى صورة بهذا الشكل مميزات التطبيق وجود جدولين الجدول الاول : tblHolidaySettings هذا الجدول وظيفته هى التأشير على ايام العطلات الاسبوعية تبعا للمؤسسة وبذلك يتم تلوين ايام العطلات لتكون مميزة باللون الاحمر وهذا مثال لاختيار يوميى الجمعة والسبت الجدول الثانى : هذا الجدول وظيفتة اضافة تواريخ العطلات الرسمية للدولة و وصف العطلة عند الانتهاء من تسجيل كل العطلات الرسمية للدولة فى الجدول وبعد فتح منتقى التواريخ تبعا لكل شهر تظهر قائمة بالاعياد والمناسبات الرسمية ويتم تغيير لون خلفية اليوم ليكون معروفا من خلال النظر انه عطلة رسمية وبمجرد التحرك من الاسهم فى لوحة المفاتيح للمرور على الايام او اختيار اليوم بضغطة زر واحدة من الفأرة يتم ظهور وصف العطلة الرسمية فى اسفل مربعات الايام كما بالشكل التالى لاختار اليوم اما بالنقر مرتين على رقم اليوم او تحريك علامة الدائرة الزرقاء لتحديد اليوم من خلال ازرار الاسهم من لوحة المقاتيح ثم الضغط على زر اختيار والموجود بالاسفل يسار النموذج زر الامر المسمى اليوم الحالى ينقل فورا الدائرة الزرقاء الى رقم اليوم الذى يوافق تاريخ اليوم يمكن تغيير اتجاه ترتيب الارقام لتبدأ من اليمين الى اليسار او العكس من خلال الزر الموجود بجوار زر اليوم الحالى : ⇋ طريقة استدعاء الدالة لتعمل مع اى مربع نص يستخدم لادخال و كتابة التواريخ تكون كالاتى عمل زر امر بجوار مربع النص وفى منشئ التعبير لحدث النقر لهذا الزر يتم استدعاء الدالة بالشكل التالى على ان يتم تغير الوصف و اسم مربع النص تبعا لاغراض التصميم =CalendarFor([اسم مربع النص فى النموذج],"اكتب الوصف الدال على مربع نص التاريخ :") ملاحظة الوصف الذى سوف يتم كتابته اثناء استدعاء الدالة سوف يطهر فى اعلى يمين النموذج تحت زر الامر الغاء وان كان مربع النص الخاص بالتاريخ يحتوى بالفع على تاريخ سوف تجد هذا التاريخ ايضا تحت هذا الوصف وشرح الوظائف المختلفة للازرار من لوحة المفاتيح التى يمكن التعامل معها بسهولة موجود فى الزر اعلى اليسار " ؟ " اتمنى لكم تجربة شيقة واتمنى ان اكون قدمت اليكم شيئا عمليا ويعود عليكم بالنفع تم اضافة اصدار جديد لتنقيح وتفادى بعض الاخطاء بتاريخ 22/09/2024 - ضبط اسهم زيادة او نقصان الشهور والسنوات تبعا لترتيب واجهة ترتيب التواريخ ( يمين / يسار ) - ضبط الفتح التلقائى لقائمة السنوات او الشهور لاغلاقها اذا كانت مفتوحة بدلا من اعادة فتح القائمة مرة اخرى عند تكرارا الضغط رقم الاصدار الجديد 4 Handler - calendar (V3).zip Handler - calendar (V4).accdb

بارك الله فيك استاد @أ / محمد صالح كود جميل يمكننا استخدامه في حالة عدم الرغبة بالاحتفاظ بالارقام على القائمة الرئيسية الاصلية

بارك الله لك أستاذ محمد وهذا جهدي المتواضع في كود يحذف الموجود في قائمة الاستثناءات ويبقي غير الموجود وفي نفس العمود Sub FilterUniqueItems() Dim rngA As Range, rngB As Range, cell As Range Dim dict As Object, outputRow As Long Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("الرئيسية") Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Sheets("استثناءات") Set rngA = ws.Range("A1:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row) Set rngB = ws2.Range("A1:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row) Set dict = CreateObject("Scripting.Dictionary") For Each cell In rngB dict(cell.Value) = 1 Next cell outputRow = 1 For Each cell In rngA If Not dict.exists(cell.Value) Then ws.Cells(outputRow, "A").Value = cell.Value outputRow = outputRow + 1 End If Next cell ws.Range("A" & outputRow & ":A" & ws.Cells(Rows.Count, "A").End(xlUp).Row).ClearContents MsgBox "Done by mr-mas.com",,"M.A.S" End Sub بالتوفيق للجميع

إجابتي بدون رؤية الملفات؛ لأني على الهاتف حاليا. المعادلة هي مجرد معادلة بحث عن الرقم الموجود في الخلية m12 وجلب القيم من العمود الثالث في النطاق المسمى prod للوصول إلى النطاقات المسماة من تبويب معادلات formulas ثم إدارة الأسماء name manager بالتوفيق

بارك الله فيكم جميعا ولإثراء الموضوع وتحقيقا لهوايتي المفضلة اختصار الأكواد يمكنك أخي صاحب الاستفسار أن تضع هذا الكود مكان الإجراء القديم Sub REs_Data() lr = Sheets("Data").Cells(Rows.Count, 1).End(xlUp).Row lr2 = Sheets("CAll").Cells(Rows.Count, 1).End(xlUp).Row For r = 2 To lr myval = Evaluate("=IFERROR(INDEX(CAll!$C$2:$C$" & lr2 & ",MATCH(B" & r & ",CAll!$A$2:$A$" & lr2 & ",0)),"""")") Range("E" & r).value = IIf(myval = "", Range("E" & r).value, myval) Next r MsgBox "Done by mr-mas.com", , "M.A.S" End Sub بالتوفيق

وعليكم السلام ورحمة الله تعالى وبركاته ادن انفترض اننا لدينا ورقتين الاولى باسم الرئيسية والثانية باسم استثناءات القائمة الرئيسية للارقام على ورقة الرئيسية بداية من الخلية A3 الى غاية A10000 (يمكنك تعديلها بما يناسبك) قائمة الارقام المرغوب إزالتها موجودة في ورقة إستثناءات بداية من الخلية A2 الى غاية A10000 (يمكنك تعديلها بما يناسبك) مكان استخراج الأرقام بعد إزالة العدم مرغوب بها هو العمود B في حالة استخدامك لإصدارات قديمة من برنامج الأوفيس يمكنك استخدام الصيغة التالية ورقة الرئيسية الخلية B3 =IF(ISNUMBER(MATCH(A3,'استثناءات '!$A$2:$A$10000,0)), "", A3) يمكنك استخراجها بدون فراغات بعد دالك في اي عمود من اختيارك بالصيغة التالية =IFERROR(INDEX($B$3:$B$10000,MATCH(0,COUNTIF(D2:$D$2,$B$3:$B$10000)+(COUNTIF($B$3:$B$10000,$B$3:$B$10000)<>1),0)),"") اما في حالة استخدامك للنسخ الحديثة وهدا أفضل دائما يمكنك استخدام احدى المعادلات التالية =FILTER(الرئيسية!A3:A10000, (ISERROR(MATCH(الرئيسية!A3:A10000, 'استثناءات '!A2:A10000, 0))) * (LEN(الرئيسية!A3:A10000) > 0)) او =FILTER(الرئيسية!A3:A10000, (ISERROR(MATCH(الرئيسية!A3:A10000, 'استثناءات '!A2:A10000, 0))) * (الرئيسية!A3:A10000 <> 0)) كما في المثال المرفق phone_numbers.xlsx في حالة الرغبة باستخدام الاكواد يمكنك استخدام هدا Sub Extract_the_main() Dim i&, b&, n&, xMatch As Boolean Dim OneRng1 As Variant, OneRng2 As Variant Dim Cnt() As Variant, tmp As Object Dim dest As Worksheet: Set dest = Sheets("الرئيسية") Dim WS As Worksheet: Set WS = Sheets("استثناءات") OneRng1 = dest.Range("A2:A" & dest.Cells(dest.Rows.Count, "A").End(xlUp).Row).Value OneRng2 = WS.Range("A2:A" & WS.Cells(WS.Rows.Count, "A").End(xlUp).Row).Value Set tmp = CreateObject("Scripting.Dictionary") For i = 1 To UBound(OneRng2, 1) If Not IsEmpty(OneRng2(i, 1)) And Not tmp.exists(OneRng2(i, 1)) Then tmp.Add OneRng2(i, 1), True End If Next i xMatch = False ReDim Cnt(1 To UBound(OneRng1, 1), 1 To 1) b = 1 n = 0 For i = 1 To UBound(OneRng1, 1) If Not IsEmpty(OneRng1(i, 1)) Then If tmp.exists(OneRng1(i, 1)) Then xMatch = True ElseIf OneRng1(i, 1) <> 0 Then Cnt(b, 1) = OneRng1(i, 1) b = b + 1 n = n + 1 End If End If Next i If Not xMatch Or n = 0 Then MsgBox "لم يتم العثور على أي تطابق بين البيانات", vbExclamation, "نتائج التصفية" Exit Sub End If dest.Range("C2:C" & dest.Rows.Count).ClearContents If b > 1 Then dest.Range("C2").Resize(b - 1, 1).Value = Cnt End If MsgBox "تم تصفية البيانات بنجاح" & vbCrLf & "عدد الأرقام المصفاة: " & n, vbInformation, "ورقة " & dest.Name End Sub مع امكانية النسخ لنفس الورقة ( الرئيسية ) او ورقة مغايرة في المرفق التالي phone_numbers vba.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب اخي الصيغة التالية '=IFERROR(INDEX(Feuil1!B$2:B$200, AGGREGATE(15, 6, ROW(Feuil1!$B$2:$B$200) / ($F$3=Feuil1!$A$2:$A$200), ROW(Feuil2!D1))-1), "") او =IFERROR(INDEX(Feuil1!B$2:B$200,SMALL(IF($F$3=Feuil1!$A$2:$A$200,ROW(Feuil1!$B$2:$B$200)-1),ROW(Feuil2!D1))),"") recherche 1.xlsx