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

وعليكم السلام ورحمة الله وبركاته بعد ملاحظة الاستاذ ابو عارف تم نعديل الملف في مشاركتى التالية

السلام عليكم جرب التعديل في الملف Option Explicit Sub CircleLowGrades() Dim ws As Worksheet Dim gradeRanges As Variant Dim maxRanges As Variant Dim cell As Range Dim maxCell As Range Dim maxGrade As Double Dim shp As Shape Dim i As Integer, j As Integer Dim gradeRange As Range, maxRange As Range Set ws = ThisWorkbook.Sheets("شهادةنصف") gradeRanges = Array(ws.Range("D13:P13"), ws.Range("D30:P30"), ws.Range("D47:P47")) maxRanges = Array(ws.Range("D12:P12"), ws.Range("D29:P29"), ws.Range("D46:P46")) For Each shp In ws.Shapes If shp.Name Like "Circle*" Then shp.delete Next shp For i = LBound(gradeRanges) To UBound(gradeRanges) Set gradeRange = gradeRanges(i) Set maxRange = maxRanges(i) For j = 1 To gradeRange.Cells.Count Set cell = gradeRange.Cells(j) Set maxCell = maxRange.Cells(j) If IsNumeric(maxCell.Value) Then maxGrade = Val(maxCell.Value) Else maxGrade = 0 End If If IsNumeric(cell.Value) Then If Val(cell.Value) < maxGrade Then Call DrawCircle(ws, cell) End If ElseIf cell.Value = "غ" Or cell.Value = "غـ" Or cell.Value = "صفر" Then Call DrawCircle(ws, cell) End If Next j Next i End Sub Sub DrawCircle(ws As Worksheet, cell As Range) Dim shp As Shape Set shp = ws.Shapes.AddShape(msoShapeOval, cell.Left + 2, cell.Top + 2, cell.Width - 4, cell.Height - 4) shp.Name = "Circle" & cell.Address(False, False) shp.Line.ForeColor.RGB = RGB(255, 0, 0) shp.Fill.ForeColor.RGB = RGB(255, 255, 255) shp.Fill.Transparency = 1 End Sub test1.xlsb

تفضل أخي Option Explicit Sub test() Dim i, j, tbl, k, lastRow As Long, rng As Range, c As Range, s As String Dim dic As Object, WS As Worksheet, dest As Worksheet Dim a, headers, result, colArr, tmp As Variant Set WS = Sheets("يومية المقاولين") With Application .ScreenUpdating = False .Calculation = xlCalculationManual Set dic = CreateObject("Scripting.Dictionary") With WS a = .Range("E7:M" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value headers = Array("م", "التاريخ", "العدد", "المورد", "الصنف", "القائم", _ "الفارغ", "الصافي", "السعر", "القيمة") End With colArr = Array(3, 4) ' المورد (G) و الصنف (H) For Each tmp In colArr dic.RemoveAll For i = 1 To UBound(a, 1) s = Trim(CStr(a(i, tmp))) If Len(s) > 0 And Not dic.exists(s) Then dic(s) = Empty s = Replace(s, "/", "_"): s = Replace(s, "\", "_") On Error Resume Next Set dest = Sheets(s) On Error GoTo 0 If dest Is Nothing Then Set dest = Sheets.Add(, Sheets(Sheets.Count)) dest.Name = s dest.DisplayRightToLeft = True dest.Rows("9").RowHeight = 20 Else dest.Range("A9:J" & dest.Rows.Count).Clear End If With dest.Range("A9:J9") .Value = headers: .Font.Bold = True: .Interior.Color = RGB(204, 255, 255) End With tbl = 0 For j = 1 To UBound(a, 1) If Trim(CStr(a(j, tmp))) = s Then tbl = tbl + 1 Next j ReDim result(1 To tbl, 1 To UBound(a, 2)) tbl = 1 For j = 1 To UBound(a, 1) If Trim(CStr(a(j, tmp))) = s Then For k = 1 To UBound(a, 2) result(tbl, k) = a(j, k) Next k tbl = tbl + 1 End If Next j dest.Range("B10").Resize(UBound(result, 1), UBound(result, 2)).Value = result dest.Range("A10:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row).Value = _ Evaluate("ROW(" & dest.Range("A10:A" & dest.Cells(dest.Rows.Count, "B").End(xlUp).Row).Address & ")-9") On Error Resume Next lastRow = dest.Columns("A:J").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 If lastRow = 0 Then lastRow = 9 Set rng = dest.Range("A9:J" & lastRow) With rng .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter .Borders.LineStyle = xlNone: .ColumnWidth = 10 End With For Each c In rng.Rows If Application.WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next c End If Set dest = Nothing Next i Next tmp WS.Activate .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub الزرع v3.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته بعد الظغط على زر الإظهار قم بسحب الصور

السلام عليكم ساشرح لك بمثال لنفرض ان الملف 1 به الكود الثالي Sub SortData() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة1") With ws.Sort .SortFields.Clear .SortFields.Add Key:=ws.Range("I8:I73"), Order:=xlDescending .SetRange ws.Range("A8:AH73") .Header = xlNo .Apply End With End Sub وتريد تقل الكود الى الملف 2 حيث تريد عمود الفرز مثلا العمود M واول صف به بيانات هو الصف 10 واخر صف به بيانات هو الصف 120 واول عمود به بيانات B واخر عمود به بيانات هو العمود BA الخطوات :- تعديل الكود ليتناسب مع التغيرات في الملف 2 السطر في الكود .SortFields.Add Key:=ws.Range("I8:I73"), Order:=xlDescending السطر السابق خاص بالعمود المطلوب فرزه I8 تعنى بداية فرز البيانات الصف 8 للعمود I تهاية الفرز لتفس العمود الصف 73 الان تريد ان تعدل في السطر حسب الملف2 الملف 2 المطلوب عمود الفرز M واول صف به بيانات هو الصف 10 فتكتب بدل M10 -I8 واخر صف 120 فنستبدل M120 - I73 فيكون السطر النهائي .SortFields.Add Key:=ws.Range("M10:M120"), Order:=xlDescending وكذلك يتم التغيير في السطر .SetRange ws.Range("A8:AH73") هذا النطاق يحتوي على جميع الخلايا من العمود A إلى AH ومن الصف 8 إلى 73. ,والملف 2 الخلايا من العمود Bإلى BAومن الصف 10إلى 120. فيصبح SetRange ws.Range("B10:BA120") فيصبح الكود النهائي Sub SortData() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("ورقة1") With ws.Sort .SortFields.Clear .SortFields.Add Key:=ws.Range("M10:M120"), Order:=xlDescending .SetRange ws.Range("B10:BA120") .Header = xlNo .Apply End With End Sub بالتوفيق

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) أشارككم اليوم حلاً برمجياً لمشكلة شائعة تواجه مطوري و مبرمجي تطبيقات آكسيس عند التعامل مع اللغة العربية . المشكلة تتمثل في الحاجة لتغيير لغة النظام (System Locale) إلى العربية لضمان عرض النصوص العربية بشكل صحيح في التطبيق ، وضمان عمل المشروع دون مشاكل . 🎯 المشكلة: - عدم ظهور النصوص العربية بشكل صحيح في بعض أجزاء التطبيق - الحاجة المتكررة لتغيير إعدادات النظام يدوياً - صعوبة شرح الخطوات للمستخدمين النهائيين ✨ الحل: قمت بتطوير دالة برمجية تقوم بـ: 1. فحص لغة النظام الحالية 2. تغيير لغة النظام إلى العربية بشكل تلقائي 3. ضبط جميع الإعدادات الضرورية (CodePage, Locale, Keyboard Layout) 4. إعادة تشغيل النظام بشكل آمن لتطبيق التغييرات 🔑 المميزات: - تنفيذ التغييرات بنقرة زر واحدة - رسائل واضحة باللغة الإنجليزية للمستخدم - معالجة الأخطاء بشكل احترافي - تأكيد موافقة المستخدم قبل إجراء التغييرات - إتاحة وقت كافٍ لحفظ الملفات قبل إعادة التشغيل 📝 ملاحظات هامة: - سيتم إعادة تشغيل الجهاز بعد تطبيق التغييرات - الكود يعمل على جميع إصدارات Windows الحديثة وهذه صورة توضيحية للخطوات التي كان على المستخدم العادي أو المبرمج تنفيذها حتى يتلافى مشكلة اللغة العربية :- الكود المستخدم في المديول :- Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare PtrSafe Function GetACP Lib "kernel32" () As Long #Else Private Declare Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare Function GetACP Lib "kernel32" () As Long #End If Private Const MSG_CHANGE_LANGUAGE As String = "Your program will not function correctly; the unicode language must be changed to Arabic. Would you like to proceed with changing the unicode language?" Private Const MSG_RESTART_NOTE As String = "Note: The computer will restart after the change" Private Const MSG_TITLE As String = "Change System Language" Private Const MSG_RESTART_SOON As String = "The computer will restart in 15 seconds" Private Const MSG_SAVE_FILES As String = "Please save all open files" Private Const MSG_CANT_RUN As String = "The project cannot run without changing the system language to Arabic" Private Const MSG_ERROR As String = "System error occurred. Please contact your administrator" Private Function IsArabicLanguage() As Boolean Dim CodePage As Long CodePage = GetACP() IsArabicLanguage = (CodePage = 1256) End Function Public Function SetArabicLocale() As Boolean On Error GoTo ErrorHandler If Not IsArabicLanguage() Then Dim response As VbMsgBoxResult response = MsgBox(MSG_CHANGE_LANGUAGE & vbCrLf & MSG_RESTART_NOTE, _ vbQuestion + vbYesNo + vbDefaultButton2, _ MSG_TITLE) If response = vbYes Then Dim fso As Object Dim txtFile As Object Dim filePath As String filePath = Environ$("TEMP") & "\ChangeToArabic.bat" Set fso = CreateObject("Scripting.FileSystemObject") Set txtFile = fso.CreateTextFile(filePath, True) With txtFile .WriteLine "@echo off" .WriteLine "chcp 1256" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v Default /t REG_SZ /d 00000401 /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v InstallLanguage /t REG_SZ /d 00000401 /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v LocaleName /t REG_SZ /d ar-JO /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v Locale /t REG_SZ /d 00000409 /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v sLanguage /t REG_SZ /d ARA /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v sCountry /t REG_SZ /d Jordan /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v iCountry /t REG_SZ /d 962 /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage"" /v ACP /t REG_SZ /d 1256 /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage"" /v OEMCP /t REG_SZ /d 1256 /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage"" /v MACCP /t REG_SZ /d 10004 /f" .WriteLine "reg add ""HKCU\Keyboard Layout\Preload"" /v 1 /t REG_SZ /d 00000401 /f" .WriteLine "control.exe intl.cpl,, /f:""C:\Windows\System32\intl.cpl""" .WriteLine "timeout /t 5" .WriteLine "shutdown /r /t 15 /c ""سيتم إعادة تشغيل الجهاز بعد ( 15 ثانية ) لتطبيق إعدادات اللغة العربية"" /f" End With txtFile.Close Dim shellApp As Object Set shellApp = CreateObject("Shell.Application") shellApp.ShellExecute filePath, "", "", "runas", 1 MsgBox MSG_RESTART_SOON & vbCrLf & MSG_SAVE_FILES, vbInformation SetArabicLocale = True Else MsgBox MSG_CANT_RUN, vbCritical SetArabicLocale = False End If Else SetArabicLocale = True End If Exit Function ErrorHandler: MsgBox MSG_ERROR, vbCritical SetArabicLocale = False End Function طبعاً رسالة التنبيه تم كتابتها باللغة الإنجليزية . في متغيرات متعددة ( السبب هو إحدى المحاولات للكتابة بالعربية مع تشفير النص ( Unicode ) ) . ولكني تجاهلت الفكرة لاحقاً . الآن يمكنك استدعاء الدالة في أول نموذج لك بالشكل التالي :- SetArabicLocale عند وجود اللغة العربية هي لغة الترميز في نسخة الويندوز ، لن تظهر لك رسالة ضرورة تغيير لغة الترميز الى العربية . ولم اقم بإضافات كبيرة خارج إطار الموضوع ، وللمبرمج حرية التعديل والإستفادة من الكود حيثما وكيفما يشاء . الملف المرفق مفتوح المصدر 👈 [ LanguageCheck.accdb ]

مخازن كامل باس ورد 0 الثلاجات مخازن 20215.rar

السلام عليكم و رحمة الله و بركاته أخي جرب التعديل انا جربت أزرار يعمل تماما في ورقتين ، و الماكرو كيو آركود خليتها يعمل عند ضغط على الزر الجديد Create Qrcode فقط متى ما شئت لا مع تحديث خلايا انت جربه و اخبرني بنتيجة ان شاء الله اساعدك رغم خبرتي في اكسل قليلة لانني اعمل في اكسس أكثر من اكسل . أنشطة 2025 (1).xlsb

يجب أخي تعديل النطاق المرغوب داخل الكود مثلا With WS ' نطاق البيانات a = .Range("E7:O" & .Cells(.Rows.Count, "E").End(xlUp).Row).Value ' عناوين رؤوس الأعمدة headers = Array("م", "التاريخ", "العدد", "المورد", "الصنف", "القائم", "الفارغ", _ "الصافي", "السعر", "القيمة", "متوسط سعر البرنيكة", "متوسط وزن البرنيكة") End With النطاق الهدف On Error Resume Next lastRow = dest.Columns("A:L").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 If lastRow = 0 Then lastRow = 9 Set rng = dest.Range("A9:L" & lastRow) الزرع v4.xlsm

مراعاة لسياسة المنتدى ، انصحك بفتح موضوع جديد ، ومتابعين معك إن شاء الله صديقنا . ملاحظة :- ارسل فقط ما له علاقة بالمشكلة ، وليس المشروع كاملاً

الف شكر تعبتك معايا بس لو تشرح التعديل على كود الفلتره يبقى كتر خيرك

كليك يمين على ايقونة نموذج في نافذة أكواد ثم ضغط على اختيار Export File احفظ نموذج في اي مكان في الجهاز خطوة 2) افتح برنامجك افتح نافذذة أكواد كليك يمين عند ايقونات عاصر ثم اختار Emport File ثم اذهب الى ملف الذي احفظته و دبل كليك عليه وقد تم استراد النموذج بنجاح بالتوفيق،،،

السلام عليكم ورحمة الله وبركاته عاشت ايدك اخي الكريم ،ممتاز الكود شغال 100% حيث قمت بوضعه في حدث عند تحميل الفورم الرئيسي لقاعدة البيانات لكي يقوم بتحديث كافة الجداول اذا كان هناك تغيير من جداول sql server شكراً جزيلا على تواصلك وتعاونك معي

سؤال لحضرتك ، لماذا لا تتوجه الى البساطة في تنفيذ أفكارك ؟؟؟؟؟؟؟ أعتقد أنه يوجد أشخاص تعجبهم فكرة معينة في عملك ، ولكن اتجاهك الى الغموض يشتت أفكار بعض الأشخاص للحصول على طلبهم . كما أنه في طريقة شرحك يوجد نوع من عدم الوضوح 😁 . حاول تبسيط الأمور في حروفك حتى يستفاد من طرحك وأفكارك 😇 .

شكرا لحضرتك kkhalifa1960 جزاك الله خيرا

بإذن الأستاذ عبدالله ضع سجل البداية في متغير يحميك من الأخطاء: firstRow = 5 'السجل المطلوب For rowIndex = firstRow + 1 To lastRow names = "" For colIndex = 2 To 13 If ws.Cells(rowIndex, colIndex).Value <> "" Then names = names & IIf(names = "", "", " - ") & ws.Cells(firstRow, colIndex).Value End If Next colIndex ws.Cells(rowIndex, 14).Value = names Next rowIndex

موضوع في غاية الاهمية شكرا لك تم حال مشكل ترميز اللغة

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

بما انني ابتعدت عن الكمبيوتر ، جرب هذا التعديل ، اولاً على دالة المديول :- Public Sub ExportReportToPDF(rptName As String, fileName As String) On Error Resume Next Dim pdfPath As String pdfPath = CurrentProject.Path & "\" & fileName & ".pdf" DoCmd.OpenReport rptName, acViewReport, , , acHidden DoCmd.OutputTo acOutputReport, rptName, acFormatPDF, pdfPath, False DoCmd.Close acReport, rptName, acSaveNo MsgBox "تم تصدير التقرير بنجاح إلى: " & vbCrLf & pdfPath, vbInformation, "نجاح التصدير" End Sub في زر الـ PDF :- Private Sub Bth_PDF_Click() Dim rptName As String, fileName As String If IsNull(Me.x_tkrer) Or Trim(Me.x_tkrer) = "" Then MsgBox "يرجى اختيار اسم التقرير قبل التصدير.", vbExclamation + vbMsgBoxRight, "" Exit Sub End If Select Case Me.x_tkrer Case "كشف الحوافز": rptName = "rep1" Case "استمارة الصرف": rptName = "rep50" Case Else MsgBox "ليس هناك تقرير بهذا الإسم", vbExclamation + vbMsgBoxRight, "" Exit Sub End Select fileName = Me.x_tkrer DoCmd.OpenReport rptName, acViewReport, , , acHidden ExportReportToPDF rptName, fileName End Sub جرب وأخبرني بالنتيجة 🤗 . طبعاً حسب علمي ، أنه لا يمكن تصدير التقرير في اكسيس دون الحاجة لفتحه حتى لو كان مخفياً ( فتح التقرير في حالة الإخفاء ) .

تفضل استاذ @alaa111 المرفق بعد التعديل حسب ما فهمت .ووافني بالرد . Microsoft Access قاعدة بيانات جديد ‫(222)‬.rar

تفضل أخي test2.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا مع سحب المعادلة للأسفل =IFERROR(INDEX(INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2); MATCH(0;COUNTIF($B$1:B2; INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2)) + IF(INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2) = ""; 1; 0); 0)); "") في حالة إستخدامك لنسخة أوفيس حديثة =IFERROR(UNIQUE(INDIRECT("Sheet1!A" & $J$2 & ":A" & $K$2)); "")

وعليكم السلام ورحمة الله تعالى وبركاته رغم أنني ليس متأكدا من طلبك بسبب كثرة الأكواد التي قمت بإرفاقها بالنسبة لعمود F (اجمالى ك وق) لا يمكن جمع القيم مباشرة إذا كانت مخزنة كنص باستخدام الدالة TEXT أعتقد انه يمكنك تجاوز هذه المشكلة بتعديل الكود لجمع القيم العددية مباشرة دون الحاجة إلى الصيغة TEXT مع الاحتفاظ بالصيغ في الأعمدة الأخرى Option Explicit Sub Test() Dim WS As Worksheet, dest As Worksheet, dict As Object Dim Code, name, Unit As String Dim cartn, Price, tmp, ColF As Double Dim ColArr, col, key, ColHard As Variant Dim lastRow, i, Irow As Long Set WS = Sheets("Sheet3"): Set dest = Sheets("رصيد") lastRow = WS.Cells(Rows.Count, 7).End(xlUp).Row If lastRow < 2 Then Exit Sub ColHard = Array("كود الصنف", "اسم الصنف", "وحدة الصنف", "سعر الصنف", "عدد الكراتين", "إجمالي ك وق", "ك", "ق") With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With dest.Range("A2:H" & dest.Rows.Count).ClearContents Application.ErrorCheckingOptions.BackgroundChecking = False Set dict = CreateObject("Scripting.Dictionary") Irow = 2 For i = 2 To lastRow Code = Trim(CStr(WS.Cells(i, 7).value)) name = Trim(WS.Cells(i, 6).value) Unit = Trim(WS.Cells(i, 4).value) Price = Val(WS.Cells(i, 5).value) cartn = Val(WS.Cells(i, 3).value) If Code <> "" Then If dict.Exists(Code) Then dict(Code)(3) = dict(Code)(3) + cartn Else dict.Add Code, Array(name, Unit, Price, cartn) End If End If Next i With dest .Range("A1:H1").value = ColHard For Each key In dict.Keys .Cells(Irow, 1).value = key .Cells(Irow, 2).Resize(1, 4).value = dict(key) .Cells(Irow, 7).Formula = "=INT(E" & Irow & "/C" & Irow & ")" .Cells(Irow, 8).Formula = "=MOD(E" & Irow & ",C" & Irow & ")" Irow = Irow + 1 Next key .Cells(Irow, 1).value = "المجموع الكلي" ColF = 0 For i = 2 To Irow - 1 If .Cells(i, 5).value <> 0 And .Cells(i, 3).value <> 0 Then tmp = Int(.Cells(i, 5).value / .Cells(i, 3).value) + (.Cells(i, 5).value Mod _ .Cells(i, 3).value) / .Cells(i, 3).value Else tmp = 0 End If .Cells(i, 6).value = Format(tmp, "0.0") ColF = ColF + tmp Next i .Cells(Irow, 6).value = Format(ColF, "0.0") ColArr = Array("E", "G", "H") For Each col In ColArr .Cells(Irow, col).Formula = "=SUM(" & col & "2:" & col & (Irow - 1) & ")" Next col End With With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With MsgBox "تمت العملية بنجاح", vbInformation End Sub اجمالى2 V1.xlsm

يمكنك إظافة السطور التالية لتحديد التنسيق الدي يناسبك Dim ColArr As Variant, col As Variant ColArr = Array("H", "I", "J", "K") For Each col In ColArr With dest.Range(col & "5:" & col & dest.Rows.Count) .NumberFormat = "dd/mm/yyyy" End With Next col العقود v3.xlsb

احسنت استاذنا الغالى / محمد هشام يوجد ملحوظة بسيطة وهى عند تقسيم الموظفين بناء على التاريخ يظهر تنسيق بيانات التاريخ ارقام فى اعمدة معينة وهذا الكود المعدل البسيط بعد اذن استاذنا Option Explicit Sub SplitData() Dim crWS As Worksheet, dest As Worksheet, OnRng As Variant, data As Variant Dim n As Integer, x As Integer, MonthArr As String, sDate As Date Dim lastRow As Long, i As Long, Irow As Long, lr As Long Dim f As Worksheet, arr As Variant, v As Variant Dim dateCol As String ' لتخزين حرف عمود التاريخ Set crWS = Sheets("العقود") dateCol = "J" ' حدد حرف عمود التاريخ هنا arr = Array("العقود", "") lastRow = crWS.Cells(crWS.Rows.Count, dateCol).End(xlUp).Row If lastRow < 5 Then Exit Sub With Application .ScreenUpdating = False: .DisplayAlerts = False .Calculation = xlCalculationManual ' تعطيل العمليات الحسابية للتسريع End With Application.ErrorCheckingOptions.BackgroundChecking = True For Each f In ThisWorkbook.Worksheets If f.Name <> crWS.Name Then v = Application.Match(f.Name, arr, 0) If IsError(v) Then f.Delete End If Next f OnRng = crWS.Range(dateCol & "4:" & dateCol & lastRow).Value ' تصحيح تحويل التاريخ وتنسيقه *قبل* الكتابة إلى الورقة For i = 1 To UBound(OnRng, 1) If Len(OnRng(i, 1)) > 0 Then ' التعامل مع تنسيقات التاريخ المختلفة (بما في ذلك مع وجود نقطتين) If InStr(OnRng(i, 1), ":") > 0 Then OnRng(i, 1) = Replace(OnRng(i, 1), ":", "/") If IsDate(OnRng(i, 1)) Then sDate = CDate(OnRng(i, 1)) n = Month(sDate) x = Year(sDate) MonthArr = Choose(n, "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") Set dest = tmp(MonthArr & " " & x, crWS.Rows(4)) Irow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 data = crWS.Range("B" & (i + 3) & ":N" & (i + 3)).Value ' كتابة البيانات dest.Range("B" & Irow).Resize(1, UBound(data, 2)).Value = data ' تعيين تنسيق التاريخ *مباشرة* بعد كتابة التاريخ dest.Cells(Irow, dateCol).NumberFormat = "dd/mm/yyyy" ' تنسيق عمود التاريخ المحدد ' تنسيق الأعمدة H و I و K dest.Cells(Irow, "H").NumberFormat = "dd/mm/yyyy" dest.Cells(Irow, "I").NumberFormat = "dd/mm/yyyy" dest.Cells(Irow, "K").NumberFormat = "dd/mm/yyyy" With dest.Range("A5:A" & dest.Cells(dest.Rows.Count, dateCol).End(xlUp).Row) ' استخدام dateCol هنا أيضًا .Value = Evaluate("ROW(" & .Address & ")-4") End With With dest lr = .Columns("A:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row .Columns("A:M").AutoFit .Rows("5:" & lr).RowHeight = 25.5 .Range("A5:M" & lr).HorizontalAlignment = xlCenter .Range("A5:M" & lr).VerticalAlignment = xlCenter ' لا حاجة لتعيين تنسيق الرقم للعمود بأكمله هنا، فقد تم بالفعل End With End If End If Next i crWS.Activate With Application .ScreenUpdating = True: .DisplayAlerts = True .Calculation = xlCalculationAutomatic ' إعادة تمكين العمليات الحسابية End With MsgBox "تم تقسيم الموظفين بنجاح", vbInformation End Sub Function tmp(ShName As String, header As Range) As Worksheet Dim WS As Worksheet On Error Resume Next Set WS = ThisWorkbook.Sheets(ShName) On Error GoTo 0 If WS Is Nothing Then Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = ShName WS.DisplayRightToLeft = True header.Copy WS.Rows(4) End If Set tmp = WS End Function العقود.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub SplitData() Dim crWS As Worksheet, dest As Worksheet, OnRng As Variant, data As Variant Dim n As Integer, x As Integer, MonthArr As String, sDate As Date Dim lastRow As Long, i As Long, Irow As Long, lr As Long Dim f As Worksheet, arr As Variant, v As Variant: Set crWS = Sheets("العقود") arr = Array("العقود", "") ' في حالة وجود أوراق أخرى يجب الإحتفاظ بها قم بإظافتها هنا lastRow = crWS.Cells(crWS.Rows.Count, "J").End(xlUp).Row If lastRow < 5 Then: Exit Sub With Application .ScreenUpdating = False: .DisplayAlerts = False End With Application.ErrorCheckingOptions.BackgroundChecking = True For Each f In ThisWorkbook.Worksheets If f.Name <> crWS.Name Then v = Application.Match(f.Name, arr, 0) If IsError(v) Then: f.Delete End If Next f OnRng = crWS.Range("J4:J" & lastRow).Value For i = 1 To UBound(OnRng, 1) If InStr(OnRng(i, 1), ":") > 0 Then OnRng(i, 1) = Replace(OnRng(i, 1), ":", "/") Next i crWS.Range("J4:J" & lastRow).Value = OnRng For i = 1 To UBound(OnRng, 1) If Len(OnRng(i, 1)) > 0 Then If IsDate(OnRng(i, 1)) Then sDate = CDate(OnRng(i, 1)): n = Month(sDate): x = Year(sDate) MonthArr = Choose(n, "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") Set dest = tmp(MonthArr & " " & x, crWS.Rows(4)) Irow = dest.Cells(dest.Rows.Count, "A").End(xlUp).Row + 1 data = crWS.Range("B" & (i + 3) & ":N" & (i + 3)).Value dest.Range("B" & Irow).Resize(1, UBound(data, 2)).Value = data With dest.Range("A5:A" & dest.Cells(dest.Rows.Count, "J").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-4") End With With dest lr = .Columns("A:N").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row .Columns("A:M").AutoFit .Rows("5:" & lr).RowHeight = 25.5 .Range("A5:M" & lr).HorizontalAlignment = xlCenter .Range("A5:M" & lr).VerticalAlignment = xlCenter .Range("J5:J" & lr).NumberFormat = "dd/mm/yyyy" End With End If End If Next i crWS.Activate With Application .ScreenUpdating = True: .DisplayAlerts = True End With MsgBox "تم تقسيم الموظفين بنجاح", vbInformation End Sub Function tmp(ShName As String, header As Range) As Worksheet Dim WS As Worksheet On Error Resume Next Set WS = ThisWorkbook.Sheets(ShName) On Error GoTo 0 If WS Is Nothing Then Set WS = Sheets.Add(After:=Sheets(Sheets.Count)) WS.Name = ShName WS.DisplayRightToLeft = True header.Copy WS.Rows(4) End If Set tmp = WS End Function العقود v2.xlsb

أخي @بلانك فعلا الأكواد المقترحة لا تضع الخطوط وإنما لحدفها الاول لحدف الخطوط والثاني لحدف الاشكال لأنني لاحظت أنك إستخدمتها في ملفك المرفق في أول مشاركة هدا ما فهمت من طلبك الأخير رغم أن الكود الأول تم تزويدك به مسبقا جرب هدا Option Explicit Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub add_Underline() Dim lastRow As Long, OnRng As Variant, i As Long Dim Max As Integer Max = 20 Application.EnableEvents = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row OnRng = WS.Range("C3:C" & lastRow).Value For i = 1 To UBound(OnRng, 1) With WS.Cells(i + 2, "C") If IsNumeric(OnRng(i, 1)) And OnRng(i, 1) < Max Then .Font.Underline = xlUnderlineStyleSingle .Font.Color = RGB(255, 0, 0) Else .Font.Underline = xlUnderlineStyleNone .Font.Color = RGB(0, 0, 0) End If End With Next i Application.EnableEvents = True Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub '============================= Sub Supprimer_lignes() Dim lastRow As Long, i As Long lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row For i = 4 To lastRow WS.Cells(i, "C").Font.Underline = xlUnderlineStyleNone WS.Cells(i, "C").Font.Color = RGB(0, 0, 0) Next i End Sub كود لعمل خط تحت الدرجة الاقل V2.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long, OnRng As Variant, i As Long Dim WS As Worksheet: Set WS = Me Dim Max As Integer Max = 20 Application.EnableEvents = False Application.ScreenUpdating = False Application.Calculation = xlCalculationManual If Not Intersect(Target, WS.Range("C3:C" & WS.Rows.Count)) Is Nothing Then lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row OnRng = WS.Range("C3:C" & lastRow).Value For i = 1 To UBound(OnRng, 1) With WS.Cells(i + 2, "C") If IsNumeric(OnRng(i, 1)) And OnRng(i, 1) < Max Then .Font.Underline = xlUnderlineStyleSingle .Font.Color = RGB(255, 0, 0) Else .Font.Underline = xlUnderlineStyleNone .Font.Color = RGB(0, 0, 0) End If End With Next i End If Application.EnableEvents = True Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub كود لعمل خط تحت الدرجة الاقل.xlsb

وعليكم السلام ورحمة الله وبركاته يمكنك الاطلاع على الفيديو الآتي المتعلق بحل مشكلة رسالة الخصوصية كما يلي: من هنا تقبل تحياتي

Navigate to this directory [C:\Program Files (x86)\Microsoft Office\root\vfs\Windows\SHELLNEW] and make sure the file named [EXCEL12.xlsx] exists If the file doesn't exist download it from the post (I will attach it for you) then copy it to the directory in the above screenshot Create an excel shortuct and right-click on it and select [Run as administrator] Finally execute the following code Sub Test() Const SEXCELFILE As String = "EXCEL12.xlsx" Dim subKeys, WshShell As Object, fso As Object, baseKeyPath As String, sFullKeyPath As String, sDestFile As String, sSourceFile As String, i As Integer Set WshShell = CreateObject("WScript.Shell") baseKeyPath = "HKEY_CURRENT_USER\Software\Classes\" subKeys = Array(".xlsx\", "Excel.Sheet.12\", "ShellNew\") sFullKeyPath = baseKeyPath For i = LBound(subKeys) To UBound(subKeys) sFullKeyPath = sFullKeyPath & subKeys(i) If Not RegKeyExists(WshShell, sFullKeyPath) Then WshShell.RegWrite sFullKeyPath, "" Next i sDestFile = "C:\Program Files (x86)\Microsoft Office\root\vfs\Windows\SHELLNEW\" & SEXCELFILE Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FileExists(sDestFile) Then sSourceFile = ThisWorkbook.Path & "\" & SEXCELFILE If fso.FileExists(sSourceFile) Then fso.CopyFile sSourceFile, sDestFile Else MsgBox "Source File '" & SEXCELFILE & "' Not Found.", vbExclamation: Exit Sub End If End If WshShell.RegWrite sFullKeyPath & "FileName", sDestFile, "REG_SZ" Set WshShell = Nothing: Set fso = Nothing MsgBox "Done", vbInformation End Sub Function RegKeyExists(WshShell As Object, regKey As String) As Boolean On Error Resume Next WshShell.RegRead regKey RegKeyExists = (Err.Number = 0) On Error GoTo 0 End Function EXCEL12.XLSX

استفسار1.xlsx

السلام عليكم نم تعديل كود خفظ الشهادة يحيت يحفظ باسم الفصل والشعبة حسب ما هو مكتوب في الخليتين b6&b7 ولم يعد التغيير من الكود لم افهم قصدك بمحاولة التعديل على كود الترتيب اذا كان المقصود كلمة مكرر ينم الغائها فالملف المرفق فيه طلبك وان كنل تعنى شئ اخر فاوضح لي الامر ترتيب التلاميذ تصاعديا (1) - Copy.xlsm

حل بالكود في العمود b اصغط على الزر واختر الدولة وحل بالمعادلات في العمود c' المصنف_2.xlsb

تفضل المصنف_3.xlsx

وعليكم السلام ورحمة الله وبركاته حياك الله , الأمر يحتاج إلى متابعة لتحقيق المطلوب , لأنه من الصعب أن تجد شيءا جاهز لاحظ هذه الملفات برنامج موارد بشرية.xlsx شيت مرتبات.xlsx 611075288_OfficeSoft.EmploySalary-Source.zip

وعليكم السلام ورحمة الله وبركاته ما تفضل به الاستاذ حجازي يكفى وفي تفس الوقت يمكن تعديل المعادلة لتعطى الخلية فارغة =IF($B$8="";"";IFERROR(1/(1/INDEX(Monthly1;$B$8;3));"")) الملف بدون اصفار الشهادات.xlsm

من قائمة ملف اختار خيارات ثم متقدم و افعل كما بالصورة

عذرا اليك الملف ASD1.xlsb

تفضل أخي الكريم فرز عملاء.xlsm

تفضل الملف بعد التعديل. تم استخدام المعادلة =COUNTIFS(C5:C32;"";D5:D32;"";E5:E32;"<>") المصنف2.xlsx

يالرغم اننا لا نعلم اصدار الاكسل لديك ولكن الملف المرفق به كود للاصدار القديم 2003 فنا فوق وتم حفظه شيت .xls لينعامل مع الاصدار 2003 فكرة الكود الكود اذا كانت L6 و N6 فارغتان ينم طباعة كل الاستمارات اذا تم تحديد الخليتين مدى معين لعدد معين من الطلبة يتم طباعة المحدد فقط مع عدم المساس بالمعادلات الموجودة بلالاستمارة اعلمنى بالنتائج بعد التجربة شيت نتيجة.xls

السلام عليكم جرب الملف تعديل كود.xlsm

Try this solution توزيع الدرجة.xlsm

هدا ليس لدي أي علاقة بطلبك السابق (وضع الشهادات في فولدر بجوار الملف الاصلي) يرجى فتح موضوع جديد بطلبك مع إرفاق ملف للإشتغال عليه

وعليكم السلام ورحمة الله نعالى وبركاته دالة IFS هي دالة موجودة في إصدارات Excel الحديثة ولكنها غير مدعومة في Excel 2019 يمكنك استخدام دوال أخرى مثل IF المتداخلة لتحقيق نفس الوظيفة على سبيل المثال =IF(A2="","",IF(A2<5,"ضعيف",IF(A2<10,"متوسط",IF(A2<15,"حسن","ممتاز")))) أو =IF(A2="","",CHOOSE(MATCH(A2,{0,5,10,15},1),"ضعيف","متوسط","حسن","ممتاز")) يمكنك تعديل هذه الصيغ لتشمل العديد من الشروط المتداخلة حسب حاجتك إذا كنت ترغب في محاكاة دالة IFS باستخدام VBA يمكننا كتابة دالة مخصصة تقوم بالتحقق من عدة شروط في تسلسل مشابه لدالة IFS في Module قم بلصق الكود التالي Function IFS_Formula(ParamArray tmp() As Variant) As Variant Dim i As Integer For i = LBound(tmp) To UBound(tmp) Step 2 If tmp(i) Then IFS_Formula = tmp(i + 1) Exit Function End If Next i IFS_Formula = CVErr(xlErrValue) End Function واستخدام الدالة التالية =IFS_Formula(A2="","",A2<5,"ضعيف",A2<10,"متوسط",A2<15,"حسن",A2>=15,"ممتاز") في حالة لديك حاجة مستمرة لاستخدام دالة IFS فإن الحل الأكثر فعالية سيكون الترقية إلى Excel 2021 رابط التحميل https://www.mediafire.com/file/2iky3sdt2ojv6ag/Office_2016-2021-x86_x64-EN_FR.M-HICHAM.rar/file حيث تكون هذه الدالة مدعومة بشكل كامل بالتوفيق............. TEST-IFS.xlsb

وعليكم السلام وحمة الله تعالى وبركاته يمكنك تعديله بما يناسبك Option Explicit Sub sav_PDFall() ActiveSheet.Unprotect Password:="saaa" Dim i As Integer Dim folderPath As String folderPath = ThisWorkbook.Path & "\الشهادات" If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath End If For i = 1 To Range("u1") Step 3 Range("h1") = i If i <= Range("u1") Then ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ Filename:=folderPath & "\" & Range("H1").Value & ".pdf", Quality:=xlQualityMinimum, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False End If Next i ActiveSheet.Protect Password:="saaa" End Sub

السلام عليكم يالرغم من عدم وضوح الطلب لعدم اكنمال الجدول افترضت بيانات كما في ورقة2 قائمة الاسماء والتاريخ يتم انشائها بالكود حسب ما هو موجود الملف المصنف1.xlsb

تـفضل لعله المطلوب OK برنامج قراء باركود.xlsm

وعليكم السلام ورحمة الله وبركاته حسب فهمى لطلبك اليك الملف مثال (1).xlsm

للأسف المشكلة كانت في متغير تافه هو اللي عمل هذه المشكلة 🤣 ، وتم التعامل معه 🤠 LanguageCheck V 2.5.accdb