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

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

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

برنامج مراقبة المخزون بمناسبة شهر رمضان مراقبة المخزون.xlsm

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

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

يجب أخي تعديل النطاق المرغوب داخل الكود مثلا 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 عند معاينة الطباعة ..

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

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

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

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

، الصورة التي أرفقتها تُظهر 4 أزرار في مربع الحوار، وهو شيء غير ممكن عند استخدام MsgBox مباشرة في VBA، حيث يدعم MsgBox فقط حتى 3 أزرار كحد أقصى.

تفضل أخي test2.xlsx

قد أتيت به فعلاً .. و والله لضيق الوقت لم استطع رفع الملف .. 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

يمكنك إظافة السطور التالية لتحديد التنسيق الدي يناسبك 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

وعليكم السلام ورحمة الله وبركاته الموضوع طويل وشائك نوعا ما ولكن رحلة الف ميل تبدأ بخطوة وهذه هي الخطوة (خطوة جامدة) هذا ملف من هذا المنتدى فيه صلاحيات المستخدمين حسين (كلمة مروره 123) هو ال King يستطيع التحكم في ظهور وأخفاء جميع الأوراق في البرنامج وكذالك يتحكم في صلاحيات المستخدمين الباقين بينما حمد (كلمة مروره 11) لا يستطيع التحكم إلا في بعض الأوراق بحسب ما حددها له حسين إذن حسين يستطيع أن يوزع صلاحيات الأوراق وكلمات المرور على المستخدمين ممكن أن نجعل حمد كذلك يتحكم في جميع الأوراق في البرنامج بأن نكتب أمام جمع الأوراق كلمة (نعم) لا أطيل الكلام , التفاصيل داخل البرنامج المرفق تنبيه : كما قلت هذه هي الخطوة الأولى شاشة الدخول مع صلاحيات المستخدمين.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

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

Right-Click on sheet name and view code then paste the following Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Column = 1 Then If Split(Target.Value, " ")(0) = "اكتب" Or Split(Target.Value, " ")(0) = "فكر" Then Target.Interior.Color = RGB(0, 112, 192) End If End If End Sub

استفسار1.xlsx

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

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

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

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

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Sub kh_Color1() Dim Obj As Object, MyColor As Long, lr As Long, R As Long, txt As String Dim WS As Worksheet: Set WS = Sheets("قيود اليومية") Application.ScreenUpdating = False Set Obj = CreateObject("Scripting.Dictionary") MyColor = 900000 lr = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row WS.Range("A6:J" & lr).Interior.color = 800444 For R = 6 To lr txt = Trim(WS.Cells(R, "G")) If Len(txt) Then If Not Obj.Exists(txt) Then Obj.Add txt, MyColor MyColor = MyColor + 7000111 End If WS.Range(WS.Cells(R, "A"), WS.Cells(R, "J")).Interior.color = Obj(txt) Dim rColor As Long, gColor As Long, bColor As Long rColor = (Obj(txt) Mod 256) gColor = ((Obj(txt) \ 256) Mod 256) bColor = ((Obj(txt) \ 65536) Mod 256) If (rColor + gColor + bColor) / 3 < 128 Then WS.Cells(R, "A").Resize(1, 10).Font.color = RGB(255, 255, 255) Else WS.Cells(R, "A").Resize(1, 10).Font.color = RGB(0, 0, 0) End If End If Next R Set Obj = Nothing Application.ScreenUpdating = True End Sub

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

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

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

وعليكم السلام ورحمة الله تعالى وبركاته Option Explicit Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim a() As Variant, ColArr As Variant, CelArr As Variant, txt As String, i As Integer, OnRng As Range Dim WS As Worksheet: Set WS = Sheets("النموذج النهائي") Set OnRng = Me.Range("A" & Target.Row & ":AC" & Target.Row) txt = "مؤقت لمدة" If Not Intersect(Target, Me.Range("AD:AD")) Is Nothing And Me.Cells(Target.Row, "AD").Value <> "" Then If InStr(Me.Cells(Target.Row, "AD").Value, "ترحيل") > 0 Then If Application.CountA(OnRng) = 0 Then: MsgBox "لا يوجد بيانات في الصف ", vbExclamation: Exit Sub ColArr = Array("i", "G", "d", "C", "O", "U", "F", "Z") CelArr = Array("L2", "C9", "E13", "G13", "C14", "C15", "C16", "J26") ReDim a(LBound(ColArr) To UBound(ColArr)) For i = LBound(ColArr) To UBound(ColArr): a(i) = Me.Cells(Target.Row, ColArr(i)).Value: Next i WS.[C21].Value = IIf(Me.Cells(Target.Row, "Q").Value <> "", txt & " (" & Me.Cells(Target.Row, "Q").Value & ") سنوات", "") WS.[C22].Value = IIf(IsDate(Me.Cells(Target.Row, "R").Value), Format(Me.Cells(Target.Row, "R").Value, "yyyy/mm/dd"), "") WS.[C23].Value = IIf(IsDate(Me.Cells(Target.Row, "S").Value), Format(Me.Cells(Target.Row, "S").Value, "yyyy/mm/dd"), "") Application.ScreenUpdating = False : Application.EnableEvents = False On Error GoTo SubApp For i = LBound(CelArr) To UBound(CelArr): WS.Range(CelArr(i)).Value = a(i): Next i SubApp: Application.ScreenUpdating = True: Application.EnableEvents = True End If End If End Sub طلب ترحيل.xls

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

وعليكم السلام ورحمة الله وبركاته الحل بطريقتان اولا الكود Sub FillNamesInColumnN() Dim ws As Worksheet, lastRow As Long, rowIndex As Long, colIndex As Long, names As String Set ws = ThisWorkbook.Sheets("ورقة1") For colIndex = 2 To 13 lastRow = Application.Max(lastRow, ws.Cells(ws.Rows.Count, colIndex).End(xlUp).Row) Next colIndex For rowIndex = 6 To lastRow names = "" For colIndex = 2 To 13 If ws.Cells(rowIndex, colIndex).Value <> "" Then names = names & IIf(names = "", "", " - ") & ws.Cells(5, colIndex).Value End If Next colIndex ws.Cells(rowIndex, 14).Value = names Next rowIndex MsgBox "تمت العملية !", vbInformation End Sub الثاني بالمعادلات =TRIM(IF(B8<>"";B$5;"") & IF(C8<>"";"- " & C$5;"") & IF(D8<>"";" - " & D$5;"") & IF(E8<>"";" - " & E$5;"") & IF(F8<>"";" - " & F$5;"") & IF(G8<>"";" - " & G$5;"") & IF(H8<>"";" - " & H$5;"") & IF(I8<>"";" - " & I$5;"") & IF(J8<>"";" - " & J$5;"") & IF(K8<>"";" - " & K$5;"") & IF(L8<>"";" - " & L$5;"") & IF(M8<>"";" - " & M$5;"")) المعادلة طويلة ربما يكون اصدار الاكسل لديكم قديم فالكود او المعادلة تتماشى مع الاصدارات القديمة وكذلك الحديثة الملف وبه الطريقتان DATA1.xls

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

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

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

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

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

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