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

السلام عليكم ورحمة الله وبركاته الاستاذ الفاضل algammal جزاك الله كل خيرا على ثتاؤك ودعائك لي الاستاذ الفاضل Foksh تحية لك ولاخواننا في منتدى الاكسس بعد اذنكما ساطرح فكرة اخرى لطلب حبيبنا algammal حسب فهمى لطلبكم انكم تريدون البحث باسم الموظف او الرقم الوطني او من وظيفتهم طبيب كمثال اذا كان هذا الطلب فليس من الضرورى تجميع الاسماء في شيت واحد لان هذا سيزيد من حجم الملف وتكرار بيانات ليس لها ضرورة الفكرة كود يقوم بالبحث في شيت معاشات وشيت data باستخذام النطاق a5:m5 في شيت search ونتيجة البحث ينم وضعها في نفس الشيت بداية من A10 تم عمل قائمة بالاسماء بدل كنابنها ويتم تحديثها يدويا بواسطة زر وتتحدث تلقائيا عتد الانتهاء من البحث الملف المرفق يوضح الفكرة لكما ولكل اعضاء المنتدى وافر التقدير والاخترام طريقة اخرى للبحث.xlsb

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

شكرا استاذنا الفاضل محمد هشام. على اطرائك كود متقن فائف السرعة سلمت يمينك وزادك من فضله وعلمه

السلام عليكم ورحمة الله وبركاته أستاذنا ومعلمنا الفاضل، خبير الأكسس Foksh شرفٌ كبير لنا تواجدكم بيننا، فأنتم إضافة مميزة بأي مكان تحلون فيه. أتابع ردودكم وحلولكم الاحترافية باهتمام في منتدى الاكسس، ونتعلم منها الكثير، فجزاكم الله خيرًا. كما لا يفوتني أن أوجه التحية والتقدير لأخينا الحبيب، الأستاذ الفاضل algammal. تحياتي واحترامي لك أخي العزيز، وبعد إذن معلمنا، هذه محاولة متواضعة لتنفيذ طلب أخينا العزيز، حسب ما فهمته من سؤاله. أتمنى أن تقوم بتجربة الحل، وإذا كان هناك أي تعديل أو توضيح إضافي، فأنا على أتم الاستعداد . مع خالص التحية والتقدير لكما ولكل منابعى المنتدى، الكود Sub ترحيل_البيانات() Dim wsMain As Worksheet, wsNew As Worksheet Dim dict As Object, dataArray As Variant Dim i As Long, lastRow As Long, targetRow As Long Dim startTime As Double: startTime = Timer Dim sheetName As String With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False .DisplayAlerts = False .StatusBar = "جاري معالجة البيانات مع الحفاظ على التنسيقات..." End With On Error GoTo ErrorHandler Set wsMain = ThisWorkbook.Sheets("معاشات") Set dict = CreateObject("Scripting.Dictionary") lastRow = wsMain.Cells(wsMain.Rows.Count, "A").End(xlUp).Row If lastRow < 5 Then Exit Sub dataArray = wsMain.Range("A5:M" & lastRow).Value For i = 1 To UBound(dataArray, 1) sheetName = Trim(dataArray(i, 5)) If sheetName <> "" Then dict(sheetName) = Empty Next i Application.DisplayAlerts = False For Each wsNew In ThisWorkbook.Worksheets If Not wsNew Is wsMain Then If dict.exists(wsNew.Name) Then wsNew.Delete End If Next wsNew Application.DisplayAlerts = True Dim key As Variant, rowIndex As Long For Each key In dict.keys Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) wsNew.Name = key wsNew.DisplayRightToLeft = True wsMain.Range("A1:M4").Copy wsNew.Range("A1").PasteSpecial Paste:=xlPasteFormats Application.CutCopyMode = False wsMain.Rows("3:4").Copy wsNew.Rows("3:4").PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False targetRow = 5 For rowIndex = 1 To UBound(dataArray, 1) If Trim(dataArray(rowIndex, 5)) = key Then wsMain.Range("A" & rowIndex + 4 & ":M" & rowIndex + 4).Copy wsNew.Range("A" & targetRow) targetRow = targetRow + 1 End If Next rowIndex For i = 1 To wsMain.UsedRange.Rows.Count If i <= wsNew.UsedRange.Rows.Count Then wsNew.Rows(i).RowHeight = wsMain.Rows(i).RowHeight End If Next i For i = 1 To 13 wsNew.Columns(i).ColumnWidth = wsMain.Columns(i).ColumnWidth Next i Next key wsMain.Activate CleanUp: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True .DisplayAlerts = True .StatusBar = False End With ' MsgBox "تم الانتهاء في " & Format(Timer - startTime, "0.00") & " ثانية", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical Resume CleanUp End Sub الملف ترحيل البيانات من شيت إلى عدة شيتات مستقلة.xlsb

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

وعليكم السلام ورحمة الله وبركاته "جزاك الله خيرًا على دعائك الطيب، أسأل الله أن يرزقك أضعاف ما دعوت لي، وأن يبارك لك في عمرك وعملك." هذا الكود يعمل في شيت معاشات لو ربطته بزر لوحده ولكن دمجه مع كود الترحيل يحناج الى وضعه في المكان المناسب وبطريقة مناسبة بحيت يصبح الكود بهذا الشكل 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