محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته يرجى ملاحظة أنه في دالة SUMIF يجب أن تكون القيم متطابقة تماما بما في ذلك المسافات الزائدة في بداية أو نهاية النص وهذا لا ينطبق على ملفك الحالي حيث توجد بعض القيم في العمود (j) تحتوي على مسافات إضافية E5 عشاء ________ متطابقة E6 أغراض _______ تتضمن مسافة في البداية E7 اخرى _________ تتضمن مسافة في النهاية للتأكد من ذلك يمكنك نسخ القيم من العمود (O) ولصقها في العمود (J) مباشرة وإستخدام المعادلة المقترحة من الأستاد @عبدالله بشير عبدالله وستلاحظ أن النتائج تبدأ بالظهور بشكل صحيح كما يمكنك استخدام الصيغة التالية لتجاوز هذه المشكلة والتأكد من وجود تطابق بعد إزالة المسافات =IF(J13<>"", SUMPRODUCT(($F$5:$F$28)*((TRIM($E$5:$E$28)=TRIM(J13)))), "") حساب011.xlsx

جرب هدا ربما يناسبك توحيد البحث في شيت واحد v2.xlsb

السلام عليكم ورحمة الله وبركاته أولا أتقدم بجزيل الامتنان والتقدير لأساتذتنا الكرام: الأستاذة @عبدالله بشير عبدالله و @Foksh على مساهماتهم القيمة وتعاونهم العلمي الراقي والذي يعد نموذجا يحتذى به في تبادل المعرفة جميع الحلول المقدمة صراحة رائعة وتلبي المطلوب بدقة ولكن أحببت أن أثري الموضوع بفكرة قد تكون مختلفة نوعا ما وتقوم الفكرة على الاستغناء الكامل عن ورقة SEARCH بما في ذلك التصفية التقليدية في النطاق A5:M5 وذلك من خلال استخدام نموذج بحث (UserForm) متكامل مرتبط مباشرة بقاعدة البيانات هذا النموذج يوفر المزايا التالية: البحث الفوري والتصفية المباشرة من ورقة DATA باستخدام قوائم منسدلة ComboBoxes ديناميكية إمكانية ترحيل النتائج إلى ورقة أخرى SEARCH عند الحاجة لذلك واجهة مرنة قابلة للتطوير تغني تماما عن الحاجة إلى أوراق وسيطة مما يجعل العمل أكثر تنظيما وسلاسة عرض عدد النتائج بعد التصفية بشكل تلقائي يشرفني أن أشارك هذه الفكرة المتواضعة في سبيل إثراء هذا العمل المميز وآمل أن تشكل إضافة مفيدة ضمن هذا الجهد الرائع تنويه: يرجى مراعاة أن حجم الصفوف المستخدمة في ورقة DATA قد يؤثر بشكل ملحوظ على سرعة تنفيذ التصفية خصوصا في الأجهزة ذات الإمكانيات الضعيفة مع خالص التقدير والاحترام للجميع توحيد البحث في شيت واحد v1.xlsb

العفو أخي @AMIRBM يمكنك الآن إعادة تحميل النسخة المحدثة من الملف من خلال المشاركة السابقة

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

ادن يمكننا استخدام الطريقة التالية Public Property Get WS() As Worksheet: Set WS = Sheets("DbSheet"): End Property Private Function ColArr(fromNum As Long, toNum As Long) As Variant Dim arr() As Long, i As Long ReDim arr(0 To toNum - fromNum) For i = 0 To UBound(arr): arr(i) = fromNum + i: Next i ColArr = arr End Function Private Sub UserForm_Initialize() Dim i As Long, j As Long, d As Object colVisu = ColArr(1, 7) Dim maxRow As Long: maxRow = 51 <===== عدد الصفوف الظاهرة على الليست بوكس Dim lastRow As Long: lastRow = WS.Cells(WS.Rows.Count, 7).End(xlUp).Row If lastRow > maxRow Then lastRow = maxRow Set WsRng = WS.Range("A2:G" & lastRow) TblBD = WsRng.Value OnRng = WsRng.Rows.Count ReDim cnt(1 To OnRng, 1 To UBound(colVisu) + 2) For i = 1 To OnRng For j = 0 To UBound(colVisu) cnt(i, j + 1) = TblBD(i, colVisu(j)) If IsDate(cnt(i, j + 1)) Then cnt(i, j + 1) = Format(cnt(i, j + 1), "dd/mm/yy") Next j cnt(i, UBound(colVisu) + 2) = i + 1 Next i With Me.ListBox1 .ColumnCount = UBound(colVisu) + 2 .ColumnWidths = "90;90;90;90;120;90;90;0" .List = cnt End With Me.ComboBox1.List = Application.Transpose(WS.Range("A1:G1").Value) Me.ComboBox1.ListIndex = 0 Me.B.Caption = "فلترة ب: " & Me.ComboBox1 Me.A.Caption = "إختيار عمود البحث" Set d = CreateObject("Scripting.Dictionary") For i = 1 To UBound(cnt): d(cnt(i, 1)) = "": Next i Me.ComboBox2.List = d.Keys: Me.ComboBox2 = "*" EnteteListBox UpLabels Hrlabel Me.tCount.Caption = "عدد الموظفين / " & ListBox1.ListCount End Sub منظومة-الشؤون-الادارية 2.xlsm

جرب هدا Sub ConvertDates() Dim WS As Worksheet, lastRow As Long, i As Long Application.ScreenUpdating = False Set WS = ActiveSheet lastRow = WS.Cells(WS.Rows.Count, "L").End(xlUp).Row For i = 2 To lastRow If IsDate(WS.Cells(i, "L").Value) Then WS.Cells(i, "M").Value = DateValue(WS.Cells(i, "L").Value) WS.Cells(i, "M").NumberFormat = "mmm dd, yyyy" Else WS.Cells(i, "M").Value = "" End If Next i Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته اخي @AMIRBM 1) الأفضل هو تجاهل الصفوف الفارغة في عمود G بدلا من تقييد العرض بـ 51 صف فقط لأنك بذلك تمنع عرض أي بيانات جديدة تضاف لاحقا بعد الصف 51 أي إدخال جديد لن يظهر في الـ ListBox الكود يصبح محدودا وغير ديناميكي 2) بعد معاينة الملف لاحظت انك اسم الجدول على ورقة العمل باسم Tableau5 بينما الكود يشير إلى Tableau1 وهذا سيؤدي حتما إلى ظهور خطأ عند التشغيل لأن الكود يبحث عن جدول غير موجود وهده النقطة يمكننا تجاوزها إدا فهمنا ما تحاول فعله بالاعتماد على نطاق البيانات مباشرة من الورقة دون الحاجة لاستخدام جدول محدد أو إسمه مما يجعل الكود أكثر مرونة ولا يتأثر بتغيير الأسماء أو حذف الجداول وكدالك عرض كل الصفوف التي تحتوي على بيانات فعلية فقط مهما كان عددها 3) إذا كنت متأكد أن تقييد العرض على 51 صف فقط هو المطلوب ويراعي ظروف عملك يمكننا تعديل الكود ليقوم بعرض أول 51 صف من البيانات الفعلية فقط في النهاية الأمر يعود لاختيارك حسب متطلباتك هل ترغب أن أعدل لك الكود بحيث يعرض فقط أول 51 صف غير فارغ في العمود G ؟ أو تفضل التعديل الديناميكي الذي يعرض كل الصفوف الفعلية ويتجاهل الفراغات ؟

وعليكم السلام ورحمة الله تعالى وبركاته، شكرًا للأخ @Foksh على مشاركته القيمة وبعد إذنه طبعا بالفعل الدالة: =TEXT(L2, "mmm dd, yyyy") مفيدة جدا لإظهار التاريخ بتنسيق واضح لكنها ترجع نصا وليس تاريخا فعليا مما قد يعيق عمليات مثل الترتيب أو الفلترة أو الحسابات المرتبطة بالتواريخ كبديل يعيد قيمة التاريخ الأصلية بدون الوقت وبشكل يمكن Excel التعامل معه كتاريخ حقيقي يمكن استخدام: =INT(L2) أو =QUOTIENT(L2, 1) كلاهما يفصل التاريخ عن الوقت تماما (وتظل قابلة للحسابات مثل التصفية والفرز) ملاحظة: تأكد من تنسيق الخلايا الناتجة كـ [تاريخ] لضمان عرضها بالشكل الصحيح وإذا كنت مهتما أيضا بفصل الوقت بشكل مستقل فيمكن استخدام: =L2 - INT(L2) وهي مفيدة إذا احتجت لاحقا إلى عرض الوقت وحده أو تحليله تحياتي وتقديري للجميع 2 تمديد.xlsx

k = Array("=COUNTIF($M$5:$M$" & lr & ", $B$3)", "=COUNTIF($F$5:$F$" & lr & ", $D$3)", "=COUNTIF($F$5:$F$" & lr & ", $G$3)") tmp.[C3].Formula = k(0): tmp.[E3].Formula = k(1): tmp.[H3].Formula = k(2) أخي الفاضل @Foksh . أولا كان سبب مداخلتي هو أنني أحببت فقط أن أشارككم أساتذتي الكرام من باب التشريف لا التكليف ورغبة مني في الإسهام قدر المستطاع في إثراء هذا الموضوع أما بخصوص كود الأستاذ بشير @عبدالله بشير عبدالله فأراه يؤدي المطلوب بكفاءة واقتدار وجهده محل تقدير الفكرة التي تطرأ في هذا السياق تتعلق بالتعامل مع نطاقات ديناميكية في الأوراق الجديدة التي يتم إنشاؤها استنادا إلى القيم الموجودة في العمود M العمود F والخلية B3-D3-وG3 إذا ماذا يحدث عند نسخ الأعمدة؟ الفكرة الجوهرية: عند إنشاء ورقة جديدة بناء على تصنيف معين (مثل عمود "النوع" أو غيره) يتم نسخ الصف الثالث الذي يحتوي على معادلات مثل COUNTIF لكن بما أن كل ورقة جديدة قد تحتوي على عدد صفوف مختلف فإن نطاق البيانات الذي تطبق عليه المعادلات قد يختلف استخدام معادلة مثل =COUNTIF($F$5:$F$10000, $D$3) فهذا نطاق ثابت (من F5 إلى F10000) ولكن في الواقع بعض الأوراق الجديدة قد لا تحتوي على هذا العدد من الصفوف وبالتالي استخدام نطاق ثابت في جميع الأوراق قد يؤدي إلى نتائج غير دقيقة أو إلى تحميل غير ضروري على المعادلات لذا جاءت فكرة جعل المعادلات ديناميكية ومرتبطة بعدد الصفوف الفعلي الموجود في كل ورقة جديدة والهدف من هذا التحديث هو تحسين الأداء وضمان دقة النتائج خاصة عند التعامل مع عدد كبير من الأوراق التي تحتوي على بيانات متفاوتة هذا التحديث يعتبر اجتهادا شخصيا لتحسين العمل وليس أمرا ضروريا لكنه يساهم بشكل كبير في جعل المعادلات أكثر مرونة وتكيفا مع محتوى كل ورقة تم استخدام الدالة SUBTOTAL داخل الكود لترقيم البيانات تلقائيا في الأوراق الجديدة نظرا لقدرتها على تجاهل الصفوف المخفية سواء تم إخفاؤها يدويا أو باستخدام الفلتر عكس الترقيم العادي تستخدم SUBTOTAL في الكود لعرض ترقيم ديناميكي يتغير تلقائيا عند تصفية البيانات مما يجعل الجداول أكثر وضوحا وسهولة في القراءة عند العمل على بيانات مفلترة أما عن سبب إضافتي لها في الكود فهو أنني لاحظت أن صاحب الموضوع الأخ المحترم @algammal يستخدم بالفعل هذه الدالة في ورقة المعاشات وبالتحديد في العمود A حيث يكتب الصيغة التالية: =IF(B5<>"",SUBTOTAL(3,$B$5:B5),"") وهذا يعكس رغبته في ترقيم الصفوف الظاهرة فقط وبالتالي كان من المنطقي الاستمرار على نفس النمط داخل الكود البرمجي لضمان تناسق النتائج ودقتها بعد تصفية البيانات كما تمت الإشارة سابقا فإن استخدام دالتي COUNTIF و SUBTOTAL في الكود ليس أمرا إلزاميا أو ضروريا بحد ذاته لكنه جاء في إطار تحسين سير العمل ورفع جودة النتائج 1) الهدف من ذلك: تقديم مخرجات أكثر دقة واحترافية 2)تحسين تجربة المستخدم عند تصفية البيانات (الفلاتر) 3) التأكد من أن المعادلات تعمل بشكل ديناميكي وسلس حتى مع تغير محتوى الأوراق 👈 ورغم أن الزميل @algammal لم يشر صراحة إلى هذه النقط إلا أننا دائما نحاول من خلال مداخلاتنا الاشتغال على مثل هذه الجوانب التقنية الدقيقة لمساعدة الإخوة الأعضاء في بناء حلول مرنة وقابلة للتوسع تتماشى مع مختلف سيناريوهات العمل ضمن ملفاتهم نعم في هذا الكود تم استخدام المصفوفات الفرعية من خلال السطر: ReDim a(1 To UBound(OnRng, 1), 1 To UBound(OnRng, 2)) المصفوفة a() تستخدم لتخزين البيانات بشكل مؤقت في الذاكرة قبل نسخها إلى ورقة العمل الجديدة هذا يساعد في تحسين الأداء بشكل كبير لأننا نعمل مع المصفوفة في الذاكرة بدلا من تعديل الخلايا مباشرة في كل مرة التحديد الديناميكي لحجم المصفوفة باستخدام ReDim يتم تحديد حجم المصفوفة بناء على البيانات الموجودة في النطاق OnRng الذي يحتوي على البيانات الفعلية وهذا يتيح للكود أن يتعامل مع نطاقات بيانات ذات حجم غير ثابت وأهميتها تخزين الصفوف التي تتطابق مع الشرط المحدد (مثل تطابق القيم في العمود الخامس مع f) مما يتيح لنا معالجتها دفعة واحدة بعد ذلك في الورقة الجديدة أخي الفاضل @Foksh أشكرك مرة أخرى على مداخلتك القيمة والتي أضافت للموضوع بعدا تقنيا هاما كما أشرت فإن استخدام الدوال والمصفوفات بهذه الطريقة لا يأتي من باب الضرورة بل هو اجتهاد لتحسين الأداء وجودة النتائج خاصة في بيئات العمل التي تعتمد على بيانات كبيرة ومتغيرة باستمرار إن مشاركتك محل تقدير واحترام ونحن نثمن حرصك على إثراء الحوار الفني بملاحظاتك الدقيقة ومداخلاتك الهادفة وأتمنى أن تكون هذه التوضيحات قد ساهمت في الفهم الكامل لاستخدام المصفوفات ودالة SUBTOTAL والمعادلات الديناميكية داخل الكود إذا كان لديك أي استفسارات إضافية أو ملاحظات أخرى فلا تتردد في طرحها فالحوار التقني بيننا يثري الجميع فمهما بلغ فهمنا أو اجتهادنا نبقى دائما في مقام التلاميذ ضمن هذا الصرح العظيم نستزيد من علم أساتذتنا وننهل من خبراتهم فالعلم بحر لا ساحل له دمتم بخير وأتمنى لك التوفيق دائما

وعليكم السلام ورحمة الله تعالى وبركاته أستاذنا الفاضل @Foksh أشكرك جزيل الشكر على كلماتك الطيبة وتقديرك الذي يعكس أخلاقك العالية تواجدك بيننا هو شرف كبير لنا وأنت بالفعل مصدر إلهام لنا جميعا في عالم الإكسس كذلك أود أن أشكر الأخ العزيز @algammal على إبداعه في تقديم طلبه بكل أدب وتقدير مشيرا إلى الجهد الكبير الذي بذله الأستاذ عبدالله في تلبية طلبه هذه اللفتة تعكس الروح الطيبة بين أعضاء المنتدى وتشجع على تبادل الخبرات بكل تقدير واحترام وهو أمر نفتقده أحيانا في بعض الحالات كما لا يفوتني أن أوجه التحية والتقدير للأستاذ الفاضل @عبدالله بشير عبدالله على مشاركته القيمة وجهوده المستمرة في دعم ومساعدة أعضاء المنتدى اسمحوا لي أن أساهم بدوري في إثراء هذا الموضوع من خلال هذا الكود المتواضع رغم أن الحلول المطروحة هنا رائعة بالفعل إلا أنني حاولت التركيز على تحسين الأداء الزمني للكود ليكون أسرع في بعض الحالات خاصة في التعامل مع البيانات الكبيرة إضافة إلى ذلك قمت بتعديل بعض النقاط لتحسين تجربة المستخدم مثل تسريع عمليات النسخ والتنسيق وتقليل التكرار في العمليات مما يساعد في تقليل الوقت المستغرق لتنفيذ الكود آمل أن تساهم هذه الإضافة في تحسين تجربتنا المشتركة في استخدام إكسل بشكل أكثر كفاءة بالطبع يسرني أن أسمع آراءكم وتعليقاتكم حول أي تحسينات إضافية يمكن أن تفيد الجميع مع خالص التحية والتقدير Sub TransferData() Const début As Long = 5: Const Height As Double = 20.25 Const départ As String = "A": Const Fin As String = "M" Const harder As String = "A3:M4" Dim CrWS As Worksheet, tmp As Worksheet, dest As Object, OnRng As Variant Dim i As Long, lastRow As Long, tbl As String, f As Variant, k As Variant Dim Irow As Long, a() As Variant, n As Long, lr As Long On Error GoTo OnError Set CrWS = Sheets("معاشات"): Set dest = CreateObject("Scripting.Dictionary") lastRow = CrWS.Cells(CrWS.Rows.Count, départ).End(xlUp).Row If lastRow < début Then Exit Sub SetApp False OnRng = CrWS.Range(départ & début & ":" & Fin & lastRow).Value For i = 1 To UBound(OnRng, 1) tbl = Replace(Trim(OnRng(i, 5)), "/", "_"): tbl = Replace(tbl, "\", "_") If Len(tbl) > 0 Then dest(tbl) = Empty Next i Application.DisplayAlerts = False For Each tmp In ThisWorkbook.Worksheets If Not tmp Is CrWS Then: If dest.exists(tmp.Name) Then tmp.Delete Next tmp Application.DisplayAlerts = True For Each f In dest.keys Set tmp = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) tmp.Name = f: tmp.DisplayRightToLeft = True CrWS.Range(harder).Copy tmp.[A3].PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False ReDim a(1 To UBound(OnRng, 1), 1 To UBound(OnRng, 2)) n = 0 For Irow = 1 To UBound(OnRng, 1) If Trim(OnRng(Irow, 5)) = f Then n = n + 1 For i = 1 To UBound(OnRng, 2) a(n, i) = OnRng(Irow, i) Next i End If Next Irow If n > 0 Then tmp.[A5].Resize(n, UBound(OnRng, 2)).Value = a CrWS.Range("A5:M" & n + 4).Copy tmp.[A5].PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False End If CrWS.Columns("A:M").Copy tmp.Columns("A:M").PasteSpecial Paste:=xlPasteColumnWidths Application.CutCopyMode = False lr = tmp.Cells(tmp.Rows.Count, départ).End(xlUp).Row For i = 1 To lr tmp.Rows(i).RowHeight = Height Next i k = Array("=COUNTIF($M$5:$M$" & lr & ", $B$3)", "=COUNTIF($F$5:$F$" & _ lr & ", $D$3)", "=COUNTIF($F$5:$F$" & lr & ", $G$3)") tmp.[C3].Formula = k(0): tmp.[E3].Formula = k(1): tmp.[H3].Formula = k(2) tmp.Range("A5:A" & lr).Formula = "=IF(B5<>"""",SUBTOTAL(3,$B$5:B5),"""")" tmp.[A4].Select Next f On Error Resume Next CrWS.Range("A5:M" & lastRow).FormatConditions.Copy tmp.Range("A5:M" & n + 4) On Error GoTo OnError CrWS.Activate CleanUp: SetApp True MsgBox "تم ترحيل البيانات بنجاح", vbInformation Exit Sub OnError: Resume CleanUp End Sub Private Sub SetApp(ByVal enable As Boolean) With Application .ScreenUpdating = enable .EnableEvents = enable .DisplayAlerts = enable .Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) End With End Sub ترحيل البيانات من شيت إلى عدة شيتات مستقلة v3.xlsb

الكود الذي عملنا عليه سابقا يقوم بتحويل الأرقام إلى عربية أو إنجليزية لكن يتم ذلك عن طريق تغيير محتوى الخلية مباشرة وهذا يؤدي إلى فقدان أي صيغة كانت موجودة في الخلية للأسف الإكسيل لا يدعم تغيير عرض الأرقام من إنجليزية إلى عربية أو العكس داخل نفس الخلية بدون التأثير على محتواها بمعنى: لا يمكنك تحويل الأرقام داخل الخلية إلى العربية دون تعديل المحتوى نفسه مجرد اقتراح قد يكون مناسبا لتنفيذ طلبك مع الحفاظ على الصيغ: يمكن إظهار الأرقام العربية بصريا فقط وذلك عبر إضافة شكل شفاف (Textbox) فوق الخلية بهذا الأسلوب تبقى الصيغ تعمل كما هي والخلية الأصلية لا تتغير لاكن يمكنك محاكاة المظهر العربي للأرقام بصريا فقط دون التأثير على الصيغ أو البيانات كما في المثال التالي تحويل الورقة بالكامل الى لغة عربية دون تغير لغة الجهاز -v4.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub Tartib() Dim WS As Worksheet, lastRow As Long, OnRng As Range Dim i As Long, ColSort As String: ColSort = "Z" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set WS = ThisWorkbook.Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then GoTo ClearApp For i = 2 To lastRow WS.Cells(i, ColSort).Value = i Next i Set OnRng = WS.Range("A2:D" & lastRow).Resize(, WS.Range(ColSort & "2").Column - 1 + 1) OnRng.Sort Key1:=WS.Range(ColSort & "2"), Order1:=xlAscending, Header:=xlNo OnRng.Sort Key1:=WS.Range("C2"), Order1:=xlDescending, _ Key2:=WS.Range("D2"), Order2:=xlAscending, _ Key3:=WS.Range("B2"), Order3:=xlAscending, Header:=xlNo WS.Range(ColSort & "2:" & ColSort & lastRow).ClearContents ClearApp: Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

طلبك أخي الكريم يتضمن عدة احتمالات لذا نرجو منك التكرم بإرفاق ملف يحتوي على بعض الأمثلة (أرقام في الأعمدة A -B -C) مع توضيح النتائج المتوقعة يدويا في العمود D ذلك سيساعدنا على فهم المطلوب بدقة وتنفيذ ما تحتاجه

جرب هدا عملاء مكررين v2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Sub test() Dim WS As Worksheet, lastRow As Long, i As Long, dict As Object Dim cnt As String, dateStr As String, tmps As Date, maxDate As Date, tbl As Long Set WS = Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row Set dict = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False For i = 2 To lastRow cnt = Trim(WS.Cells(i, 1).Value) dateStr = Trim(WS.Cells(i, 2).Value) If cnt <> "" And IsDate(dateStr) Then tmps = CDate(dateStr) If Not dict.exists(cnt) Then dict.Add cnt, Array(tmps, i) ElseIf tmps > dict(cnt)(0) Then dict(cnt) = Array(tmps, i) End If End If Next i For i = lastRow To 2 Step -1 cnt = Trim(WS.Cells(i, 1).Value) If dict.exists(cnt) Then tbl = dict(cnt)(1) If i <> tbl Then WS.Range("A" & i & ":C" & i).Delete Shift:=xlUp ' OR WS.Rows(i).Delete End If Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True End Sub

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

وعليكم السلام ورحمة الله تعالى وبركاته تحويل الورقة بالكامل الى لغة عربية دون تغير لغة الجهاز -v3 .xlsb

وعليكم السلام ورحمة الله تعالى وبركاته قم بإظافة Textbox جديدة مثلا بإسم TextBoxSearch وإظافة الأكواد التالية Private Sub TextBoxSearch_Change() Dim i As Long, count As Long, sList() As Variant Dim Search As String, tmp() As String, n() As String Search = LCase(Replace(Trim(TextBoxSearch.Text), " ", "")) If Not IsArray(r) Or UBound(r) < 0 Then Exit Sub ReDim tmp(UBound(r)) ReDim n(UBound(r)) For i = 0 To UBound(r) If InStr(LCase(Replace(r(i, 0), " ", "")), Search) > 0 Then tmp(count) = r(i, 0) n(count) = r(i, 1) count = count + 1 End If Next i If count > 0 Then ReDim sList(0 To count - 1, 0 To 1) For i = 0 To count - 1 sList(i, 0) = tmp(i) sList(i, 1) = n(i) Next i ListBox1.List = sList Else ListBox1.clear End If Counter = "عدد التقارير: " & ListBox1.ListCount End Sub "=============================== Private Sub TextBoxSearch_DblClick(ByVal Cancel As MSForms.ReturnBoolean) If Not iGblInhibitTextBoxEvents Then TextBoxSearch.value = "" End If End Sub للطباعة إختر ما يناسبك Private Sub CommandButton6_Click() On Error GoTo ClearApp If Me.ListBox1.ListIndex = -1 Then MsgBox "يرجى تحديد الملف المرغوب طباعته", vbExclamation, "إنتبــــاه" Exit Sub End If WebBrowser1.ExecWB 6, 1 '<===== ' عرض نافذة الطباعة ' WebBrowser1.ExecWB 6, 2 '<=====' طباعة مباشرة Exit Sub ClearApp: End Sub قاعدة بيانات الموظفين 3.rar

جزاكم الله خير الجزاء وكتب أجركم وجعل دعاءكم في ميزان حسناتكم أسأل الله أن يردها إليكم أضعافا من الخير وأن لا يريكم مكروها في عزيز وأن يحفظكم ومن تحبون من كل سوء

1) أولا يسعدنا أخي @saad abed أننا إستطعنا مساعدتك 2) نعم إلغاء الرسائل وتحديث الشاشة يسرع الكود بشكل كبير Sub SupApp(ByVal disable As Boolean) With Application If disable Then .ScreenUpdating = False .EnableEvents = False .DisplayAlerts = False .Calculation = xlCalculationManual Else .ScreenUpdating = True .EnableEvents = True .DisplayAlerts = True .Calculation = xlCalculationAutomatic End If End With End Sub وقد تم تطبيق ذلك في الكود باستخدام SupApp(True) لأنها توقف التحديث البصري للشاشة وتمنع ظهور رسائل التنبيه مثل هل تريد حفظ التغييرات؟ وتوقف الأحداث البرمجية مثل الأكواد المرتبطة بفتح الملفات وكدالك تعطل إعادة الحساب التلقائي للصيغ هذا ما يحسن من سرعة الكود ويقلل من وقت تنفيذ العمليات بشكل ملحوظ خاصة عند معالجة عدد كبير من الملفات

وعليكم السلام ورحمة الله تعالى وبركاته 1) الصور التي أرفقتها توضح أن ملفك يحتوي على روابط خارجية وهي تشير إلى بيانات في ملفات أخرى عند فتح الملف يحاول تحديث هذه الروابط تلقائيا وإذا لم يجد الملفات المرتبطة أو كانت غير متاحة تظهر هذه الرسائل التحذيرية يمكنك استخدام Break Link لكسر الرابط نهائيا لتفادي ظهورها مجددا 2) مجرد اقتراح الأكواد مكررة بشكل كبير يمكن استبدالها بوظيفة واحدة تقبل اسم المنطقة كمتغير بدلا من 36 ماكرو منفصل Sub filtrage(arrName As String, names As String) On Error GoTo ClearApp If ActiveSheet.AutoFilterMode = False Then Range("A1").AutoFilter ActiveSheet.Range("A1").AutoFilter Field:=1, Criteria1:="=" & arrName, Operator:=xlOr, Criteria2:="=الاجمالى" Range("B5").Value = names Range("A3").Select Exit Sub ClearApp: End Sub ثم تستدعيها مثلا بهذا الشكل Sub صندوق_التمويل() Call filtrage("صندوق التمويل", "صندوق التمويل") End Sub جرب هدا بعد كسر الإرتباطات وتنظيم الأكواد مرتبات لسنة 2025.xls

تفضل أخي بناء على نفس الفكرة السابقة أرفق لك ملف يحتوي على كودين: الكود الأول: إنشاء مجلدات وملفات بصيغة xlsb للتجربة تم تعديل الكود بحيث يمكنك: 1) اختيار البارتيشن الذي تريد إنشاء الملفات فيه 2) تحديد عدد المجلدات التي سيتم إنشاؤها 3) تحديد عدد الملفات داخل كل مجلد حسب حاجتك الكود الثاني: تحويل جميع ملفات xlsb في البارتيشن المحدد الكود يقوم بـالبحث داخل البارتيشن الذي تحدده وتحويل جميع الملفات ذات الامتداد xlsb إلى صيغة أخرى xlsx داخل البارتشن المحدد حتى وإن كانت مخزنة داخل مجلدات فرعية متداخلة Option Explicit Sub Convertfiles() Dim dl As Object, n As String, ky As String Dim files() As String, i As Long, a As Long Dim startTime As Double, confirm As VbMsgBoxResult n = "F:\" ' لا تنسى تعديل إسم البارتيشن بما يناسبك confirm = MsgBox("سيتم تحويل جميع الملفات بصيغة xlsb إلى xlsx" & vbCrLf & _ "هل تريد المتابعة؟", vbYesNo + vbQuestion, n & " " & "محرك الأقراص") If confirm <> vbYes Then Exit Sub Set dl = CreateObject("Scripting.FileSystemObject") startTime = Timer SupApp True ky = tMps(dl, n) If Trim(ky) = "" Then MsgBox "xlsb" & " " & "لم يتم العثور على أي ملفات بصيغة ", vbInformation GoTo Cleanup End If files = Split(ky, vbCrLf) a = 0 For i = LBound(files) To UBound(files) If Trim(files(i)) <> "" Then If CntFiles(Trim(files(i)), dl) Then a = a + 1 End If End If Next i MsgBox "تم تحويل" & a & " ملف بنجاح" & vbCrLf & _ "استغرق التنفيذ " & Format(Timer - startTime, "0.00") & " ثانية", vbInformation Cleanup: SupApp False End Sub Function CntFiles(filePath As String, dl As Object) As Boolean Dim wb As Workbook Dim newPath As String On Error GoTo ClearApp Set wb = Workbooks.Open(filePath, ReadOnly:=False) newPath = Replace(filePath, ".xlsb", ".xlsx") wb.SaveAs fileName:=newPath, FileFormat:=xlOpenXMLWorkbook wb.Close SaveChanges:=False If dl.FileExists(newPath) Then dl.DeleteFile filePath, True CntFiles = True End If Exit Function ClearApp: CntFiles = False If Not wb Is Nothing Then wb.Close SaveChanges:=False End Function Function tMps(dl As Object, n As String) As String Dim root As Object, list As Collection, item As Variant, result As String On Error Resume Next Set root = dl.GetFolder(n) If root Is Nothing Then Exit Function On Error GoTo 0 Set list = New Collection Call ScanFiles(dl, root, list) For Each item In list result = result & item & vbCrLf Next item tMps = result End Function Sub ScanFiles(dl As Object, folder As Object, ByRef list As Collection) Dim file As Object, subFolder As Object, fName As String fName = LCase(folder.Path) If InStr(fName, "$recycle.bin") > 0 Then Exit Sub If InStr(fName, "system volume information") > 0 Then Exit Sub For Each file In folder.files If LCase(dl.GetExtensionName(file.Name)) = "xlsb" Then list.Add file.Path End If Next For Each subFolder In folder.SubFolders ScanFiles dl, subFolder, list Next End Sub TEST4.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا هل يناسبك Option Explicit Sub FilterByNames() Dim WS As Worksheet, arr(), i&, n&, filterRange As Range Set WS = Sheets("Sheet1") If WS.AutoFilterMode Then WS.AutoFilterMode = False n = WS.Cells(WS.Rows.Count, "I").End(xlUp).Row If n < 2 Then Exit Sub ReDim arr(1 To n - 1) For i = 2 To n arr(i - 1) = WS.Cells(i, "I").Value Next i Set filterRange = WS.Range("B6").CurrentRegion With filterRange .AutoFilter Field:=2, Criteria1:=arr, Operator:=xlFilterValues End With End Sub

أظن أن الأمر ليس بالصعب يمكننا تعديل الكود ليتناسب مع طلبك بحيث يقوم بحدف الملفات سواءا بداخل البارتيشن المحدد مباشرة أو بداخل الملفات الفرعية بما أنه من الصعب تجربة الكود على الملفات الخاصة بي قمت بإنشاء بارتيشن إظافي بإسم F فقط للتجربة يمكنك تغييره بداخل الكود على حسب احتياجاتك مع إظافة كود لإنشاء ملفات بصيغة XLSB للتجربة عليها كما في المثال التالي TEST3.xlsm