محمد هشام.

وعليكم السلام ورحمة الله تعالى وبركاته أستاذنا الفاضل @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