عبدالله بشير عبدالله

وعليكم السلام ورحمة الله وبركاته "جزاك الله خيرًا على دعائك الطيب، أسأل الله أن يرزقك أضعاف ما دعوت لي، وأن يبارك لك في عمرك وعملك." هذا الكود يعمل في شيت معاشات لو ربطته بزر لوحده ولكن دمجه مع كود الترحيل يحناج الى وضعه في المكان المناسب وبطريقة مناسبة بحيت يصبح الكود بهذا الشكل With wsTarget.Range("B5:B10000") .HorizontalAlignment = xlRight .VerticalAlignment = xlCenter End With حيث wsTarget تعنى شيت معاشات حيث قمنا بتعريفها في بداية الكود بدلا من اعادة كتابة اسم الشيت كل مرة Set wsTarget = ThisWorkbook.Sheets("معاشات") اليك الملف بعد اظافة محاداة الاسماء لليمين اتمنى انى قدمت لك ما بفيد ترحيل بيانات الموظف المحال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات 7.xlsb

وعليكم السلام ورحمة الله وبركاته لديك الحق الجزء الخاص بحدود الصف الثالت With ws.Range("C3,E3,H3,J3") .HorizontalAlignment = xlCenter .VerticalAlignment = xlCenter .Font.Bold = True .NumberFormat = "0" .Borders.Weight = xlThin End With .Borders.Weight = xlThin وزن الخط رفيع يتم تعديله الى .Borders.Weight = xlMedium وزن الخط منوسط كذلك يجب تعديل With ws.Range("C3,E3,H3,J3") لانها نشمل خلايا معينة لتحديدها ويتم تعديلها لتشمل النطاق With ws.Range("B3:J3") الملف بعد التعديل ترحيل بيانات الموظف المحال للمعاش إلى شيت آخر وحذفه من قاعدة البيانات 7.xlsb لك كل الود والاحترام

السلام عليكم حسب قهمى لطلبك ترتيب حسب اللون.xlsb

وعليكم السلام ورحمة الله وبركاته قم بتحميل الملف في المشاركة السابقة يومك طيب ومبارك

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

وعليكم السلام ورحمة الله وبركاته بعد اذن استاذنا محمد هشام جرب التعديل التالي تفس الكود والتغديل في السطر arr(i - 1) = WS.Cells(i, "I").Value بالسطر arr(i - 1) = CStr(WS.Cells(i, "I").Value) الكود كاملا 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) = CStr(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

جزاكم الله خيرا وجعله في ميزان حسناتكم

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

السلام عليكم ورحمة الله وبركاته اليك ما طلبت Sub ExportCertificatesToSinglePDF() Dim lr As Long, i As Long, pageCount As Long Dim pdfPath As String, wsMain As Worksheet, tempWS As Worksheet Dim tempSheetNames As Collection Dim sh As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False Set wsMain = ThisWorkbook.Sheets("معلمين") Set tempSheetNames = New Collection wsMain.Range("m2").FormulaR1C1 = "=COUNTA('جدول عام'!R6C1:R22C1)" lr = wsMain.Range("m2").Value i = 1 pageCount = 1 Do Until i > lr wsMain.Range("m2").Value = i wsMain.Copy After:=Sheets(Sheets.Count) Set tempWS = ActiveSheet tempWS.Name = "Temp_" & pageCount tempWS.PageSetup.PrintArea = "$A$1:$i$37" tempSheetNames.Add tempWS.Name i = i + 3 pageCount = pageCount + 1 Loop pdfPath = ThisWorkbook.Path & "\الشهادات.pdf" Dim wsArray() As Variant ReDim wsArray(1 To tempSheetNames.Count) For i = 1 To tempSheetNames.Count wsArray(i) = tempSheetNames(i) Next i ThisWorkbook.Sheets(wsArray).Select ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfPath For i = 1 To tempSheetNames.Count Application.DisplayAlerts = False ThisWorkbook.Sheets(tempSheetNames(i)).Delete Application.DisplayAlerts = True Next i wsMain.Select wsMain.Range("m2").Value = 1 Application.ScreenUpdating = True Application.DisplayAlerts = True MsgBox "تم حفظ الشهادات في ملف PDF بنجاح!", vbInformation, "تم الحفظ" End Sub تحويل الشهادات الى pdf.xlsm

اللهم إنا نسألك بأسمائك الحسنى وبصفاتك العلا وبرحمتك التي وسعت كلّ شيء، أن تمنّ عليه بالشفاء العاجل، وألّا تدع فيه جرحاً إلّا داويته، ولا ألماً إلا سكنته، ولا مرضاً إلا شفيته، وألبسه ثوب الصحة والعافية عاجلاً غير آجل، وشافِه وعافِه واعف عنه، واشمله بعطفك ومغفرتك، وتولّه برحمتك يا أرحم الراحمين.

وعليكم السلام ورحمة الله تعالى وبركاته جرب الكود التالي اذا ظهر خطا بالكود ربما تحتاج تشغيل تطبيق اكسل كمسؤول Sub DeleteXLSBFromDriveD() Dim folderPath As String folderPath = "D:\" Call DeleteXLSBRecursive(folderPath) MsgBox "تم حذف جميع ملفات .xlsb من الدرايف D (حذف).", vbInformation End Sub Sub DeleteXLSBRecursive(folderPath As String) Dim fs As Object Dim folder As Object Dim subFolder As Object Dim file As Object Set fs = CreateObject("Scripting.FileSystemObject") On Error Resume Next Set folder = fs.GetFolder(folderPath) If folder Is Nothing Then Debug.Print "Cannot access folder: " & folderPath Exit Sub End If On Error GoTo 0 On Error Resume Next Dim fileCount As Long fileCount = folder.Files.Count If Err.Number <> 0 Then Debug.Print "Error accessing files in: " & folderPath & " - " & Err.Description Err.Clear On Error GoTo 0 Exit Sub End If On Error GoTo 0 If fileCount > 0 Then For Each file In folder.Files On Error Resume Next If LCase(fs.GetExtensionName(file.Name)) = "xlsb" Then SetAttr file.Path, vbNormal Kill file.Path If Err.Number <> 0 Then Debug.Print "Failed to delete: " & file.Path & " - Error: " & Err.Description Err.Clear End If End If On Error GoTo 0 Next file End If For Each subFolder In folder.SubFolders DeleteXLSBRecursive subFolder.Path Next subFolder End Sub

لم افهم ما المقصود بالتنسيق وان كنت تقصد العمود الاخير M غير ظاهر في ملف PDF فاستبدل في الكود نطاق البيانات Range("A1:L" & lastRow).ExportAsFixedFormat _ بهذا المدى Range("A1:M" & lastRow).ExportAsFixedFormat _ يعتى بدل العمود L يصبح M عمالة نظام جديد2025_2026.xlsm

السلام عليكم ورحمة الله وبركاته اليك ما طلبت عمالة نظام جديد3.36.xlsm

السلام عليكم ورحمة الله وبركاته Sub حذفالكومة() Dim c As Range Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual: Application.EnableEvents = False For Each c In ActiveSheet.UsedRange If VarType(c.Value) = vbString Then Dim txt As String: txt = Trim(c.Value) If Left(txt, 1) = "'" Then txt = Mid(txt, 2) If Right(txt, 1) = "'" Then txt = Left(txt, Len(txt) - 1) If txt <> c.Value Then c.NumberFormat = "@": c.Value = txt End If Next c Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic: Application.EnableEvents = True End Sub ازالة علامة.xlsm

السلام عليكم ورحمة الله وبركاته اليك ما طلبت جدول التفريغ22.xlsm

وعليكم السلام ورحمة الله وبركاته Private Sub Worksheet_Change(ByVal Target As Range) Dim rg As Range, cell As Range Set rg = Intersect(Target, Columns("A")) If rg Is Nothing Then Exit Sub Application.EnableEvents = False On Error GoTo CleanUp For Each cell In rg If Not IsEmpty(cell.Value) Then If Not cell.Value Like "???-###-####" Or _ IsNumeric(Left(cell.Value, 3)) Or _ Not IsNumeric(Mid(cell.Value, 5, 3)) Or _ Not IsNumeric(Mid(cell.Value, 9, 4)) Then MsgBox "الرجاء إدخال القيمة بالتنسيق الصحيح: 3 حروف-3 ارقام-4 ارقام", vbExclamation cell.ClearContents End If End If Next cell CleanUp: Application.EnableEvents = True End Sub aaa-123-4345.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب الملف يتم الحدف عند الادخال او عند اللصق Private Sub Worksheet_Change(ByVal Target As Range) Dim rngChanged As Range Dim cell As Range Dim dict As Object Dim lastRow As Long Dim ws As Worksheet Set ws = Me lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row Set rngChanged = Intersect(Target, ws.Range("A1:A" & lastRow)) If rngChanged Is Nothing Then Exit Sub Application.EnableEvents = False Application.ScreenUpdating = False Set dict = CreateObject("Scripting.Dictionary") For Each cell In ws.Range("A1:A" & lastRow) If Not Intersect(cell, rngChanged) Is Nothing Then GoTo NextCell If Not IsEmpty(cell.Value) Then dict.Add CStr(cell.Value), 1 End If NextCell: Next cell For Each cell In rngChanged If Not IsEmpty(cell.Value) Then If dict.exists(CStr(cell.Value)) Then Application.Undo ' MsgBox "القيمة '" & cell.Value & "' موجودة مسبقاً!", vbExclamation, "تنبيه" Exit For Else dict.Add CStr(cell.Value), 1 End If End If Next cell Application.EnableEvents = True Application.ScreenUpdating = True End Sub no duplicate.xlsb

السلام عليكم ورحمة الله وبركاته جرب التعديل التالي جدول التفريغ V2 (1).xlsm

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

وعليكم السلام ورحمة الله وبركاته حسب قهمي لطلبك اليك الملف في حالة تساوي القيم الاعلى يتم دكرها مع تظليل الصف Book4.xlsb

السلام عليكم ورحمة الله وبركاته لا اعتقد ان طلبك يمكن عمله بالمعادلات ولكن يمكن بالكود اكتب اسم المستخدم وكلمة السر للمدرسة وسيتم اخفاء كل الصفحات ما عدا صفحة المدرسة وصفحة main الزر الاخر لاظهار كل الصفحات فربما تحتاجه اثناء تجهيز ملفك ويمكنك حذفه لاحقا جرب الملف وات كان هناك ملاحظات اذكرها DATA.xlsb

السلام عليكم ورحمة الله وبركاته بعد اذن معلمنا واستاذنا محمد هشام جدول2.xlsm

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

ما شاء الله هديه مقبولة جزاك الله كل خير

السلام عليكم انتبه الى الملاحظة التي كتبها معلمنا الاستاذ محمد صالح مجلد C:\Windows هو مجلد نظام، ولا يُسمح للبرامج العادية (بدون صلاحيات مسؤول) بإنشاء أو تعديل ملفات بداخله وهذا هو سبب ظهور الخطأ بالماوس الايمن على تطبيق اكسل وليس ملف الاكسل قم باختيار تشغيل كمسؤول وسيعمل الكود وينشئ الملف وقد فمت بالتجرية وكانت تاجحة بالتمام والكمال نحياني