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

Select your range C2:C32 > Home tab > Conditional Formatting > New Rule > Put the following formula =ISODD(CEILING(ROW()-1,5)/5) Click Forma button > Fill tab > Select a color of your choice Do the same steps but with the following formula and a different color =ISEVEN(CEILING(ROW()-1,5)/5)

السلام عليكم تفضل التعديل حسب فهمي لطلبك so-1.rar

Sub Test() Dim Command_Buttons, ws As Worksheet, Prompt As String, Title As String, Project As Integer Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set ws = ActiveWorkbook.Worksheets("Master") Prompt = "Sort Will Take Some Time. Please Wait" Command_Buttons = vbYesNo + vbMsgBoxRtlReading Title = "Do You Want To Sort After The Recent Changes?" Project = MsgBox(Prompt, Command_Buttons, Title) If Project = vbYes Then With ws.Sort .SortFields.Clear .SortFields.Add Key:=Range("BV8"), Order:=xlAscending .SortFields.Add Key:=Range("BT8"), Order:=xlDescending .SortFields.Add Key:=Range("C8"), Order:=xlAscending .SetRange Range("B8:BW6053") .Header = xlYes .Apply End With End If Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Call MsgBox("Sort Done", , "Thanks Allah") End Sub

لا يوجد حلقات مفقودة تم تعديل حل أستاذ سليم في نسب الخصم من أستاذ بن علية وهذا تعديل بداية ونهاية الخصم ويمكن استعمال دالة trunc أو round للحصول على عدد المنازل العشرية المطلوب في المبلغ إن شاء اللّه هو المطلوب بالتوفيق نسب شرائح الخصم.xlsx

تفضل التعديل 1678743215_.accdb

السلام عليكم ورحمة الله كنت أنتظر أن يقوم أحد الإخوة الكرام بإنشاء ماكرو للقيام بهذه العملية وهذا لم يكن، لهذا قمت بتحضير ما تريده في الملف المرفق باستعمال المعادلات... وللضرورة قمت بتغيير التنسيقات على الجداول وإضافة المعادلات المناسبة لعمل المطلوب (يرجى أن لا تقوم بحذف الصفوف أو الأعمدة لئلا تخسر المعادلات)... يبقى لتغييراتك أن تقوم بحجز فقط عدد المناصب -عدد الأساتذة- حسب المواد في "جدول 1" (جدول المواد) وعدد الأفواج -عدد الأقسام- حسب الشعبة والمستوى- في "جدول 2" (جدول الأقسام) والمعادلات تقوم باللازم لملء الجداول الأخرى (حتى الجدول 3 في ورقة Data)... والله أعلم... جدول ديناميكي.xlsx

تم حذف هذا السطر وهذا السطر يحذف صف خالي من البيانات ثم يعيد الترتيب للطلبة .SortFields.Clear

Private Sub Workbook_Open() If Hex(CreateObject("Scripting.FileSystemObject").Drives.Item("D:").SerialNumber) <> "F8BCE74D" Then MsgBox "Message 1" ThisWorkbook.Close True End If If Date >= DateValue("12/12/2021") Or Sheets("Sheet2").Range("A48") = "mosaad" Then MsgBox "Expired", vbExclamation If InputBox("Enter Password") <> "123" Then Sheets("Sheet2").Range("A48") = "AA" MsgBox " Message 2 " ThisWorkbook.Save Application.Quit End If End If End Sub

جميعا بإذن الله

سلمت يداك يا غالي

جزاك الله خير اتحلت عندي المشكلة والمعادلة تمام اشتغلت بشكر حضرتك وبشكر الاستاذ lionheart والاستاذ مصطفي محمود

وعليكم السلام لم تذكر ماهو الشرط حتى يعمل التنسيق الشرطي

نظرا لوجود معادلة في العمود F ويكون ناتجها 0 في حالة عدم وجود أرقام ينبغي تعديل معادلة العد في الخلية R4 إلى =COUNTIFS(B:B,Q4,F:F,">"&0) بالتوفيق

اشكرك اخي الفاضل وتمت التجربة على ورقة 2 المرفقة في الملف ادناه ، يعطي النتائج صحيحة في المبالغ كما هو مبين ، ولكن في الاعداد ليس صحيح العمود الاول في العدد لا يعطي مظبوط ولا اعرف السبب على الرغم اني مطبق المعادلات وتم تظليله بالأحمر الأعمدة TT.xlsx

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

أخي الكريم اعذرني طريقة تنظيم الملف لا تساعد في الوصول للمطلوب تحتاج أولا إلى استعمال تنسيق الوقت 24 لضبط مواعيد الفترة الثانية وكل المواعيد بعد 12 ظهرا لأنها مثلا تعتبر 12:45 أكبر من 1:00 وأقترح توفير عمودي موعد الحضور في الفترتين وكتابتهم في خليتين أعلى الجدول لأنهم ثابتان طوال الشهر بعد الحصول على مدة التأخير الصحيحة يمكن عمل الشروط الخاصة بالخصم عليها فيما يخصص دقائق التأخير وهذه معادلة مقترحة لحساب تأخير 1 وتأخير 2 بالتوفيق دوام ماهر الغيلي.xlsx

In cell S5, put the formula and drag down and left =COUNTIFS($C$5:$C$400,$R5,F$5:F$400,"<>" & "")

وفي حالة انك تريد ان يبقى ال ID رقم وليس نص test2Q - Copy.accdb

تفضل اخي.. بالمناسبة كود الاستاذ @kanory مضبوط وكان يعطيك خطأ لان في مثالك الاول الكود كان نص .. وفي مثالك الثاني رقم test2Q.accdb

كود اخي الوزير يعمل بكفاءة .... كيف لا يصفي الباركود ؟؟؟؟؟؟؟

Sub Test() Dim x, temp, myDir As String, fn As String, wsName As String myDir = ThisWorkbook.Path & "\" fn = "B.xlsx" wsName = ActiveSheet.Name If Dir(myDir & fn) = "" Then MsgBox "Workbook Not Found", vbExclamation: Exit Sub On Error Resume Next x = ExecuteExcel4Macro("'" & myDir & "[" & fn & "]" & wsName & "'!R1C1") temp = Err.Number On Error GoTo 0 If (temp = 0) * (Not IsError(x)) Then With ActiveSheet.Range("A1:A8") .Formula = "='" & myDir & "[" & fn & "]" & wsName & "'!F4" .Value = .Value End With Else MsgBox "Worksheet Not Found", vbExclamation End If End Sub

أخي الكريم تركيبة الملف لا تسمح بعمل معادلة واحدة للجميع يتم سحبها أفقيا ورأسيا لذلك يتم تحديد عمود المنتج الخاص بالفرع واستعماله في المعادلة فمثلا المنتج الرابع في الفرع الثاني عموده j لذلك معادلة العدد =COUNTIFS(L:L,O15,J:J,"<>") ومعادلة المبلغ =SUMIFS(J:J,L:L,O15) بالتوفيق

وعليكم السلام ورحمة الله وبركاته فقط استبدل من الكود التعديل التالي: 'set the Data source Set rst = CurrentDb.OpenRecordset("Select [barcode] From [test_order_tbl] Where " & "' & myWhere & '")

Here's a code but too long. First delete all the cells on the second worksheet then run the macro Sub Test() Const sRow As Integer = 6 Dim a, ws As Worksheet, sh As Worksheet, v As Long, i As Long, ii As Long, k As Long, c As Long, x As Long, cr As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(1) Set sh = ThisWorkbook.Worksheets(2) With sh.Cells .Clear: .UnMerge End With a = ws.Range("G4:H15").Value v = ws.Range("M18").Value ReDim b(1 To ws.Range("H16").Value, 1 To v + 2) For i = LBound(a) To UBound(a) For ii = 1 To a(i, 2) k = k + 1 b(k, 1) = a(i, 1) b(k, UBound(b, 2)) = ws.Cells(21 + ii, i + 1).Value Next ii Next i sh.Cells(sRow + 1, v + 2).Value = "Names" With sh.Range("A" & sRow + 1) .Value = "Subjects" .Offset(1).Resize(k, UBound(b, 2)).Value = b End With a = ws.Range("L4:M17").Value ReDim b(1 To 1, 1 To v): k = 0 For i = LBound(a) To UBound(a) For ii = 1 To a(i, 2) k = k + 1 b(1, k) = a(i, 1) & IIf(a(i, 2) > 1, Space(1) & CStr(ii), Empty) Next ii Next i sh.Range("B" & sRow + 1).Resize(, k).Value = b a = ws.Range("N4:N17").Value c = 2 For i = LBound(a) To UBound(a) If Not IsEmpty(a(i, 1)) Then x = x + 1 Select Case x: Case 1: cr = RGB(255, 255, 0) Case 2: cr = RGB(248, 203, 173) Case 3: cr = RGB(169, 208, 142) End Select With sh.Cells(sRow, c) .Value = x .Resize(, a(i, 1)).Merge .Resize(, a(i, 1)).Interior.Color = cr .Offset(1).Resize(, a(i, 1)).Interior.Color = cr End With c = c + a(i, 1) End If Next i With sh .Cells.ReadingOrder = xlRTL .Cells.HorizontalAlignment = xlCenter .Cells.VerticalAlignment = xlCenter With .Range("A" & sRow).CurrentRegion .Font.Name = "Times New Roman" .Font.Size = 14: .Font.Bold = True .Borders.Value = 1 .Rows.RowHeight = 18 .Columns.ColumnWidth = 8.43 .Columns(1).ColumnWidth = 14.5 With .Columns(.Columns.Count) .ColumnWidth = 14.5 .Interior.Color = RGB(255, 192, 0) .Cells(1).Interior.Color = xlNone End With End With End With Application.ScreenUpdating = True End Sub

ابوعبدالله .. ابوجودي شكرا لكما لإثراء الموضوع .. جزيتم خيرا انا مع تخصيص نموذج للسري فقط .. يكون المعيار في مصدر بياناته اظهار السري فقط

جزاك الله خيرا استانا الفاضل @ابا جودى على هذا العمل الرائع واثراءا للموضوع اسمح لي بتطبيق الفكرة بشكل اخر مختصر بعض الشىء Private Sub XH_S() If Me.sec.Value = "سري" Then Me.Label12.Visible = True Else Me.Label12.Visible = False End If End Sub Private Sub Form_Current() Me.مربع_تحرير_وسرد7.SetFocus XH_S End Sub Private Sub Form_Open(Cancel As Integer) XH_S End Sub Private Sub مربع_تحرير_وسرد7_AfterUpdate() Me.Filter = "noo =" & Me.مربع_تحرير_وسرد7 Me.FilterOn = True Me.Requery If Me.sec.Value = "سري" Then ' Me.Visible = False If InputBox("الرجاء ادخال كلمة السر لفتح النموذج", "فتح النموذج") = "123" Then Me.Label12.Visible = False Else ' Me.Visible = False Me.Label12.Visible = True End If End If End Sub b21.accdb تحياتي

أسعدكم الله وبارك فيكم ،، وهذا خط نسخ منقط راقي من إعداد مجمع الملك فهد لطباعة المصحف بالمدينة المنورة،، KFGQPC-Dot-Font.zip

السلام عليكم بعض التصويب في معادلة أخي سليم بالملف المرفق... إن شاء الله تفي الغرض المطلوب.. بن علية حاجي Naser_Masry_2.xlsx

Dim rst As Recordset Set rst = Me.RecordsetClone rst.MoveFirst Do Until rst.EOF If rst![رقم العملية] = Me![T4] Then MsgBox " السجل مكرر ", , " تنبيه" Me.Undo DoCmd.CancelEvent Exit Do End If rst.MoveNext Loop rst.Close F05.rar

الطريقة الثانية هنا الاستبدال بالاختيار ، عن طريق بلوكات يتم حفظها و تستدعي يدويا او كما يسمي Building Block و الطريقة كالتالي لنفرض أنك تريد توفير وقت كتابة جملة السلام عليكم و رحمة الله وبركاته اكتبها فى الملف لاول مرة ثم اخترها و اضغط ALT+F3 سيظهر لك المربع التالي و سنحفظها باسم السلام ضمن العبارات المحفوظة Building Block و هكذا تم حفظها و لاستدعاءها من قائمة Insert اختار Quick Parts Building Blocks organizers ثم اختار الجملة التي تريد ادراجها و سيتم ادراج الجملة المحفوظة المطلوبة و طبعا يمكنك اختصار الخطوات عن طريق اضافة ال quick Parts الى قائمة الاختصارات السريعة فتظهر كايقونة يمكن الوصول اليها سريعا و اختصار الخطوات السابقة كما هو مبين فى الصورة التالية ثانياً : من ناحية اخرى ستجد الوورد يقترح عليك الاستبدالات المسجلة عندما تكتب بعض الجروف دون الحاجة لادراج المكونات يدويا مثلما هو مبين فى الصورة التالىة و كل ما عليك هو ضغط Enter ليتم ادراج الجملة بالكامل 😄 ثالثاً: أيضا هناك حل آخر اذا لم يظهر لديك الاقتراح كما سبق ان تكتب كلمة السلام ثم تختارها دون زيادة مسافات فى النهاية ثم تضغط F3 و سيتم الاستبدال مباشرة من القائمة المخزنة