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

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

السلام عليكم جرب التعديل في الملف 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 بالتوفيق

العفو اخى بالنسبه للتعديل فالسجلات التى ذكرتها لم يكن لها سجلات فالنموذج reference وحقل Idd فارغ لذلك كانت البيانات المضافه تسجل ولاكن ليست لاى Idd فقمت بارسال الايدى مع الفلتره عن طريق OpenArgs وعند الفتح يقوم باسناده لـ Idd ان شاء الله يكون الشرح سهل ومفهوم ولو فى استفسار اسال وان شاء الله نوضحه بالتوفيق

السلام عليكم و رحمة الله و بركاته أخي جرب التعديل انا جربت أزرار يعمل تماما في ورقتين ، و الماكرو كيو آركود خليتها يعمل عند ضغط على الزر الجديد 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

وعليكم السلام ورحمة الله تعالى وبركاته بطريقة أخرى Option Explicit Sub test() Dim WS As Worksheet, tbl As Long, tmp As Long, i As Long Dim n As String, Max As Long, ky As Boolean Max = 34 Set WS = Sheets("ورقة1") Application.ScreenUpdating = False Application.Calculation = xlCalculationManual On Error Resume Next tbl = WS.Columns("B:M").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 tbl = IIf(tbl = 0, 6, tbl) tbl = IIf(tbl > Max, Max, tbl) WS.Range("N6:N" & tbl).ClearContents For tmp = 6 To tbl n = "" ky = False For i = 2 To 13 If WS.Cells(tmp, i).Value <> "" Then n = IIf(n = "", WS.Cells(5, i).Text, n & " - " & WS.Cells(5, i).Text) If Not ky Then WS.Cells(tmp, 14).NumberFormat = WS.Cells(tmp, i).NumberFormat ky = True End If End If Next i WS.Cells(tmp, 14).Value = n Next tmp Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub DATA V1.xlsb

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

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

هذا يسعدنا ، والحمد لله أولا وآخراً ,, في حال انتهت المشكلة كما أخبرتنا ، لا تنسى ان تقوم بإغلاق الموضوع باختيار .

ولا تزعل خالص بسبب عدم وجود ال id اتفضل DB3_3_1.accdb

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

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

بعد التجربة .. فعلا عند فتح التقرير في وضع (معاينة قبل الطباعة) لا تظهر الصورة .. 🤷‍♂️ ولكنها تظهر في وضع (معاينة التقرير) فقط .. ولا تظهر عند التصدير لل PDF كذلك .. وهذا بسبب أن الأكسس لا يتعرف على الأجزاء الشفافة لصور ال PNG عند معاينة الطباعة ..

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

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

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

جزاك الله خيرا .. جميل جدا وتكثر الحاجة اليه ليتك ابقيت على الجزء الخاص بالفحص ضمن المديول كدالة .. وان لا يكون هذا النموذج هو نموذج البداية وانما يتم استدعاؤه من الدالة في نموذج البداية عند تحقق الشرط السبب ان نموذج البداية عند المبرج يتيم وحيد ينقله لجميع برامجه .. يتضمن فحص الجداول المرتبطة ، ويتأكد من رقم النسخة والحماية .. ---------------- يمكنني عمل ذلك .. بكل يسر وسهولة ... ولكن انت المهدي والمتفضل ..

شكرا جزيلا لكما وبارك فيكما وجزاكما كل خير وزادكما الله من علمه

بما انني ابتعدت عن الكمبيوتر ، جرب هذا التعديل ، اولاً على دالة المديول :- 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 جرب وأخبرني بالنتيجة 🤗 . طبعاً حسب علمي ، أنه لا يمكن تصدير التقرير في اكسيس دون الحاجة لفتحه حتى لو كان مخفياً ( فتح التقرير في حالة الإخفاء ) .

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا مع سحب المعادلة للأسفل =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)); "")

قد أتيت به فعلاً .. و والله لضيق الوقت لم استطع رفع الملف .. Desktop.zip

وعليكم السلام و رحمة الله و بركاته سبب المشكلة عدم وجود متغير tmp . hg و اليك الكود بعد تعديل Sub Copy_Transfer_WORD() Dim WS As Worksheet Dim Rng As Range, j As Range, Irow As Range Dim x As Long, r As Long, lastRow As Long Dim i As Integer, Ary As Variant Dim Cnt() As String Dim arr() As String Dim tmp As Range Set WS = Sheets("الانشطة") lastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row Application.DisplayAlerts = False Application.ScreenUpdating = False Msg = MsgBox("؟" & " " & "Word " & ":" & " تصدير التقرير بصيغة", vbYesNo, WS.Name) If Msg <> vbYes Then Exit Sub n.Visible = xlSheetVisible: n.Cells.UnMerge Set tmp = n.Range("A1:l" & n.Rows.Count) Cnt() = Split("A-A,D-C,E-D,F-E,G-F,H-G,I-H,J-I", ","): tmp.Clear For i = 0 To UBound(Cnt) arr = Split(Cnt(i), "-") Set Rng = n.Range(arr(1) & n.Rows.Count).End(xlUp) WS.Range(arr(0) & "4:" & arr(0) & lastRow).Copy Destination:=Rng Next i rngA = Split("C", ","): rngB = Split("B", ",") For i = LBound(rngA) To UBound(rngA) WS.Range(rngA(i) & "4:" & rngA(i) & lastRow).Copy With n.Range(rngB(i) & "1") .PasteSpecial Paste:=xlPasteValues Application.CutCopyMode = False End With Next i n.Columns("A").SpecialCells(xlBlanks).EntireRow.Delete lr = n.Cells(n.Rows.Count, "A").End(xlUp).Row Set A = n.Rows(1): Set b = n.Rows(2): Set d = n.[A1:I1]: Set E = n.Range("A3:I" & lr) A.RowHeight = 75: b.RowHeight = 40: b.Font.Bold = True: b.Font.Size = 14 d.Merge: d.Interior.Color = RGB(192, 192, 192) n.[A2:I2].Interior.Color = RGB(215, 238, 247): n.[H2:I2].Merge E.Interior.ColorIndex = xlNone: E.Font.Name = "AdvertisingBold": E.Font.Size = 13 F = n.Cells(2, n.Columns.Count).End(xlToLeft).Column + 1 n.Range(n.Cells(2, 1), n.Cells(lr, F)).Borders.Weight = xlThin Ary = Array(5, 15, 38, 38, 38, 15, 15, 15, 15) For x = 0 To UBound(Ary) n.Columns(x + 1).ColumnWidth = Ary(x) Next x Set Irow = n.Range("A3", n.Cells(n.Rows.Count, "A").End(xlUp)) For Each j In Irow.Rows If j.RowHeight < 20 Then: j.RowHeight = 30: Else j.EntireRow.AutoFit Next n.Range("b3:b" & n.Rows.Count).NumberFormat = "yyyy/mm/dd" n.Range("A:I").EntireColumn.HorizontalAlignment = xlCenter n.Range("A:I").EntireColumn.VerticalAlignment = xlCenter With n.Range("A3:A" & n.Cells(Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-2") End With WS.Activate: ExcelToWordSheet1 n.Visible = xlSheetVeryHidden Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub

وعليكم السلام ورحمة الله تعالى وبركاته رغم أنني ليس متأكدا من طلبك بسبب كثرة الأكواد التي قمت بإرفاقها بالنسبة لعمود 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

وعليكم السلام بالمعادلات aw1.xlsx

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

إدا كنت قد إستوعبت طلبك بشكل صحيح ربما هدا سيوفي بالغرض Option Explicit Sub CreateDossiers() Dim a As Variant, lastRow As Long, i As Long, msg As String Dim Dossiers As String, Fld As String, Patch As String Dim nCarte As String, nEmploy As String, tyCont As String Dim tbl As Object, Fname As String, fCount As Integer Dim ScrWS As Worksheet: Set ScrWS = Sheets("ورقة1") Set tbl = CreateObject("Scripting.Dictionary") lastRow = ScrWS.Cells(ScrWS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then Exit Sub a = ScrWS.Range("B2:D" & lastRow).Value Dossiers = ThisWorkbook.Path & "\" Fld = Dossiers & "عقد ثابت\" Patch = Dossiers & "عقد مؤقت\" If Dir(Dossiers, vbDirectory) = "" Then MkDir Dossiers If Dir(Fld, vbDirectory) = "" Then MkDir Fld If Dir(Patch, vbDirectory) = "" Then MkDir Patch For i = 1 To UBound(a, 1) If Trim(a(i, 3)) = "ثابت" Then tbl(Trim(a(i, 1)) & " - " & Trim(a(i, 2))) = "ثابت" End If Next i fCount = 0 For i = 1 To UBound(a, 1) nCarte = Trim(a(i, 1)): nEmploy = Trim(a(i, 2)): tyCont = Trim(a(i, 3)) If nCarte <> "" And IsNumeric(nCarte) And nEmploy <> "" And tyCont <> "" Then Fname = nCarte & " - " & nEmploy If tbl.Exists(Fname) Then If Dir(Fld & Fname, vbDirectory) = "" Then MkDir Fld & Fname fCount = fCount + 1 End If Else If Dir(Patch & Fname, vbDirectory) = "" Then MkDir Patch & Fname fCount = fCount + 1 End If End If End If Next i msg = IIf(fCount > 0, "تم إنشاء " & fCount & " من المجلدات بنجاح", "جميع المجلدات موجودة مسبقا") MsgBox msg, vbInformation End Sub عقود V2.xlsb

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

وعليكم السلام ورحمة الله تعالى وبركاته حاول دمج الأكواد السابقة في كود واحد لتتمكن من طباعة وصل معين أو عدة وصولات من إختيارك بالطريقة التالية Sub Choose_the_print() Dim tmp As Variant, arr As Variant, n As Range Dim OnRng As String, xInput As String, a(1 To 6) As String Dim WS As Worksheet: Set WS = Sheets("ورقة1") a(1) = "H2:L16": a(2) = "N2:R16": a(3) = "T2:X16": a(4) = "H18:L32": a(5) = "N18:R32": a(6) = "T18:X32" xInput = InputBox("يرجى إدخال أرقام الوصولات للطباعة" & vbCrLf & "مفصولة بفاصلة (-) مثل: 3-2-1", "إختيار الوصولات") If Trim(xInput) = "" Then: MsgBox "لم يتم إدخال أي أرقام يرجى المحاولة مرة أخرى", vbExclamation: Exit Sub tmp = Split(xInput, "-") For Each arr In tmp If IsNumeric(Trim(arr)) Then If Val(arr) >= 1 And Val(arr) <= 6 Then OnRng = a(Val(arr)) Set n = WS.Range(OnRng) n.PrintOut Copies:=1, Collate:=True Else MsgBox "رقم الوصل " & arr & " غير موجود يرجى التأكد", vbExclamation Exit Sub End If Else MsgBox "إدخال خاطئ " & arr, vbExclamation Exit Sub End If Next arr MsgBox "تمت الطباعة بنجاح", vbInformation End Sub مثال.xlsm

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

جرب هذا الملف maachat3.xlsm

برنامج حسابات شركات المقاولات المتكامل The Fastest ERP 2025 مع الكراك رابط تحميل البرنامج https://www.mediafire.com/file/vdcle99uuj6umxq/The+Fastest+EXE_2025.rar/file روابط شرح البرنامج على يوتيوب YouTube https://www.youtube.com/playlist?list=PLchJFI-EXcEi2ryUFq3lW3STScg7O4yOZ .مميزات البرنامج. - الحسابات العامة والختامية طبقا لمعايير المحاسبة الدولية - حسابات النقدية والبنوك ومتابعة حركة الشيكات وخطابات الضمان والنتبيه بمواعيد الاستحقاق - تعدد العملات - إدارة حسابات الأصول الثابتة ومتابعة حياذة كل اصل وحساب الاهلاك بشكل تلقائى - مراقبة المخازن - مديول كامل لشؤون العاملين الاجور والمرتبات مع ربط البرنامج بجهاز البصمة - مقايسات المشروعات وتسجيل المستخلصات مع عمل تحليل للتكاليف التقديرية للمشروع - تحليل تكاليف المواقع الفعلية والمقارنة بالتكاليف التقديرية وتحديد الانحرافات - عقود مقاولين الباطن ومستخلصاتهم - سراكى المعدات وسراكى العمال - المشتريات المحلية والمستوردة – مع تحليل تكاليف البضاعة المستوردة - حسابات العملاء والموردين ومراقبة حد الائتمان واعمار الديون - اماكانية ربط المرفات بالبرنامج واستدعائها بسهولة ويسر - ربط البرنامج بمنظومة الفاتورة الالكترونية مع رفع الفواتير الى المنظومة تلقائيا بشكل فردى او بالجملة Select All