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

هذه طريقتي في إعادة تسمية العناصر الكثيرة دفعة واحدة في النموذج بأسماء متسلسلة مثل : ( Box2 , Box1 , ... ) هو كود وقد عملت له نموذج لتسهيل العمل .. 🙂 الكود يقوم أيضا بترتيب وتنسيق العناصر في شكل منتظم لتسهيل عملية التصميم 😊 إقرأ الملاحظات جيدا قبل أن تطبق 😉👌🏻 النموذج : النتيجة ستكون هكذ : ( من >>>> إلى ) >>>> >>>> للاستفادة من هذا النموذج .. قم بنقل النموذج لقاعدة البيانات عندك وسيتعرف تلقائيا على النماذج التي عندك 🙂 ملف التحميل : إعادة تسمية العناصر مع الترتيب بواجهة مرنة.accdb

برنامج طباعة الاختبارات بطريقة الاتمته (الاصدار الثاني) برمجة وتصميم الاستاذ صالح احمد محمد ربيع هذا البرنامج اهداء لجميع المدارس برنامج طباعة الاختبارات الاصدار ٢.xls

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

بعد إذن أخينا الفاضل محمد هشام هذا الكود بنفس طريقتك Sub ww() Dim sh As Worksheet, i As Double: i = 2 For Each sh In Sheets If sh.Name <> "Sheet1" And sh.Name <> "Sheet2" And sh.Name <> "Sheet3" And sh.Name <> "Sheet7" Then Sheets("Sheet1").Hyperlinks.Add Sheets("Sheet1").Cells(i, 1), "", "'" & sh.Name & "'!a1", sh.Name, sh.Name sh.Hyperlinks.Add sh.Cells(1, 5), "", "'Sheet1'!a1", "Sheet1", "رجوغ" sh.Cells(1, 5).Font.Size = 30: i = i + 1 End If Next MsgBox "Dobe by mr-mas.com" End Sub رغم أني أعتقد كان من السهل على حضرتك عمل التعديل إن كنت حضرتك صاحب الكود أما إن كنت استخدمت كود غيرك فمن الواضح أنك لم تقم بمدارسته وفهمه بالتوفيق

السلام عليكم بناءا على طلب بعض الاخوة اقدم لكم برنامج صغير لارشفة الصور برنامج ارشفه.accdb

تم تعديل البرنامج مع اضافة الباركود اسفل الورقة. *ملاحظة هامة* يتم تثبيت خطوط الباركود المرفقه مع البرنامج لكي يظهر الباركود بصورة صحيحة اسفل ورقة الاختبار برنامج طباعة الاختبارات تعديل نهائي٣.rar

السلام عليكم و رحمة الله اليك شرح الكود المطلوب ارجو ان اكون قد وفقت Sub LastTest() '-------------------- Dim i As Long, ws As Worksheet, Rng As Range Dim C As Range, p As Integer, x Dim Shp As Shape, Nam As String Set ws = Sheets("Sheet2") Application.ScreenUpdating = False Range("AO5:BB100") = "" ' مسح النطاق الذى سوف يتم ارسال بيانات التلاميذ الضعاف Set Shp = ws.Shapes(Application.Caller) ' تعريف الشكل حسب العنوان المكتوب عليه Nam = Shp.TextEffect.Text ' الاسم المكتوب على الشكل ws.Range("AQ1") = " الطلاب الضعاف اقل من 65 % ل" & Nam ' عبارة تكتب عقب الضغط على اى زر حسب الشهر p = 4 ' لعد التلاميذ الضعاف بدلا من الصفر يعنى i = 5 ' اول صف سوف يتم العمل عليه Do While i <= 70 ' آخر صف سوف يتم العمل عليه حسب المرفق و يم تغييره بسهولة With ws Select Case Nam ' الاعمدة التى سوف يتم العمل عليها حسب اسم الشهر المكتوب على الزر Case "شهر 10" x = Array(1, 2, 3, 4, 5, 6, 7, 11, 15, 19, 23, 27, 31, 35) Case "شهر 11" x = Array(1, 2, 3, 4, 5, 6, 8, 12, 16, 20, 24, 28, 32, 36) Case "شهر 12" x = Array(1, 2, 3, 4, 5, 6, 9, 13, 17, 21, 25, 29, 33, 37) Case Else End Select For j = LBound(x) To UBound(x) ' عدد الاعمدة المطلوبة للعمل عليها و تكون مصفوفة Set Rng = .Cells(i, x(j)) ' التعريف بالنطاق و جعل كل صف على حدة كمصوفة مستقلة بذاتها For Each C In Rng ' كل خلية فى هذا النطاق y = .Cells(4, x(j)) * 0.65 ' شرط النجاح If .Cells(i, x(j)) < y Then ' اذا كان الشرط غير متوافر m = m + 1 ' عد مواد الرسوب اقل من 65% If m > 1 Then GoTo 88: ' تكفى مادة واحدة ليبدأ للعمل عليها p = p + 1 ' العد For a = 0 To 13 ' عدد الخلايا التى سيتم ترحيل البيانات اليها .Cells(p, a + 41) = .Cells(i, x(a)) ' ترحيل البيانات .Cells(p, 41) = p - 4 ' مسلسل للتلاميذ الضعاف Next End If Next Next End With 88: m = 0 i = i + 1 Loop End Sub

يمكنك استعمال هذه الدالة المعرفة Function daysnames(d As String, m As Integer, y As Long) As String Dim x As Long, s As String, days: s = "": days = Split(d, "-") For x = 0 To UBound(days) s = s & IIf(x > 0, " و", "") & Format(DateSerial(y, m, days(x)), "dddd") Next x daysnames = s End Function وطريقة استخدامها =daysnames(D2,F2,G2) وبعد استعمالها تعامل مثل الدوال الموجودة في الاكسل من حيث تحديث بيانات الخلية مباشرة بدون الضغط على زر للتحديث بالتوفيق

يمكنك تجربة هذه المعادلة =MID(A2,FIND("|AR|",A2)+4,100) بالتوفيق

وعليكم السلام Sub Test() Dim ws As Worksheet For Each ws In ThisWorkbook.Worksheets ws.Rows("1:2").RowHeight = 30 ws.Rows("3:" & Rows.Count).RowHeight = 20 Next ws End Sub

استكمالا لجهود الزملاء الأعزاء إذا كان لديك أوفيس 2021 أو 365 يمكنك وضع هذه المعادلة في I2 =UNIQUE($B$2:$D$16) أو يمكنك تعديل الإجراء المقدم من أخينا @محي الدين ابو البشر إلى Sub test() Dim a, T As String, i& a = Sheets("aaa").Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) T = a(i, 2) & a(i, 3) & a(i, 4) If Not .exists(T) Then .Add T, Array(.Count + 1, a(i, 2), a(i, 3), a(i, 4)) End If Next i Sheets("aaa").Cells(2, 9).Resize(.Count, UBound(a, 2)) = Application.Index(.items, 0, 0) End With End Sub ولوضع كود لكل مادة في العمود الأول يمكنك وضع هذه المعادلة في الخلية A2 مع سحبها لأسفل =IFERROR(INDEX(M$2:M$8,MATCH(B2&C2&D2,J$2:J$8&K$2:K$8&L$2:L$8,0))-1+COUNTIFS(B$2:B2,B2,C$2:C2,C2,D$2:D2,D2),"") بالتوفيق للجميع

عليكم السلام إذا كنت منفتحاً على استخدام ماكرو فإليك هذا وإلا .... Sub test() Dim a, w Dim T As String Dim i& a = Sheets("aaa").Cells(1).CurrentRegion With CreateObject("scripting.dictionary") For i = 2 To UBound(a) T = a(i, 2) & a(i, 3) & a(i, 4) If Not .exists(T) Then .Add T, Array(.Count + 1, a(i, 2), a(i, 3), a(i, 4), a(i, 1), a(i, 1) + IIf(a(i, 1) = 1, 199, 99)) Else w = .Item(T): w(5) = w(4) + 99: .Item(T) = w End If Next Sheets("aaa").Cells(2, 9).Resize(.Count, UBound(a, 2) + 2) = Application.Index(.items, 0, 0) End With End Sub

Sub test() Dim a, x Dim i&, ii& Application.ScreenUpdating = False a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1) Next For i = 2 To Cells(1, 9).CurrentRegion.Rows.Count For ii = 9 To 9 + Cells(1, 9).CurrentRegion.Columns.Count - 1 If Not .exists((Cells(i, ii).Value)) Then Cells(i, ii).Interior.Color = vbRed Else Cells(i, ii).Interior.Color = 16777164 End If Next: Next End With Application.ScreenUpdating = True End Sub Sub tes2() Dim a, x x = Cells(1, 9).CurrentRegion.Columns.Count Dim i&, ii& Application.ScreenUpdating = False With CreateObject("scripting.dictionary") For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, "" Next For i = 2 To Cells(1, 9).CurrentRegion.Rows.Count For ii = 9 To 9 + Cells(1, 9).CurrentRegion.Columns.Count - 1 If Not .exists((Cells(i, ii).Value)) Then Cells(i, ii).Interior.Color = vbYellow Else Cells(i, ii).Interior.Color = 16777164 End If Next: Next End With Application.ScreenUpdating = True End Sub

بالاذن من الاستاذ محمد هشام. طريقة أخرى Sub test() Range("A1:AI35").Interior.Color = xlNone For I = 14 To 15 Range("A1:AI35").Cells.Find(Range("AL" & I), , , 1).Interior.Color = vbRed Next End Sub

الأخوة الأفاضل: السلام عليكم وجدت هذا الموقع بالصدفة وبه مجموعة من الأكواد والشروحات لعل البعض يستفيد منها . https://www.isladogs.co.uk/code-samples/index.html

تفضل جرب test.xlsm

السلام عليكم ورحمة الله نعالى وبركاته بعد ادن الاستاد أ / محمد صالح بالنسبة لاظهار بيانات اليوم فقط تفضل جرب اخي Private Sub UserForm_Initialize() Dim f As Worksheet: Set f = Sheets("ورقة1") Set d = CreateObject("scripting.dictionary") Col = f.Range("B4:E" & f.[B65000].End(xlUp).Row).Value Rng = UBound(Col, 2) With Me.ListView1 .Gridlines = True .FullRowSelect = True .View = lvwReport .ColumnHeaders.Add , , "code", 0 .ColumnHeaders.Add , , "م", 30, lvwColumnCenter .ColumnHeaders.Add , , "التاريخ", 80, lvwColumnCenter .ColumnHeaders.Add , , "اسم العميل", 120, lvwColumnCenter .ColumnHeaders.Add , , "الرقم ", 60, lvwColumnCenter Cpt = 1 ' من بداية الجدول ' For i = 1 To UBound(Col) For i = UBound(Col) - 19 To UBound(Col) ' تحديد اخر 20 صف If Col(i, 2) = Date Then ' شرط تاريخ اليوم .ListItems.Add , , Col(i, 1) For k = 1 To Rng .ListItems(Cpt).ListSubItems.Add , , Col(i, k) Next k Cpt = Cpt + 1 End If Next i End With End Sub listview 2.xlsm

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

إذا كان المطلوب أن يعمل الكود في حدث التغيير في جميع الشيتات فيجب وضع الكود في هذا المصنف thisworkbook وإذا كان المقصود بالأسطر الصفوف فيمكنك استعمال هذا الكود Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If [v1] = 28 Then Sh.Rows("1363:1387").Hidden = True Sh.Rows("1361:1362").Hidden = False Else Sh.Rows("1363:1387").Hidden = False Sh.Rows("1361:1362").Hidden = True End If End Sub ويمكن اختصاره إلى هذا Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Sh.Rows("1363:1387").Hidden = IIf([v1] = 28, True, False) Sh.Rows("1361:1362").Hidden = IIf([v1] = 28, False, True) End Sub بالتوفيق

السلام عليكم أخي الكريم طرحت سؤالك على برنامج دردشة ميكروسوفت فكان الجواب كالتالي: يتم استخدام خاصية StartUpPosition في إكسل لتحديد موقع ظهور UserForm عندما يتم فتحه لأول مرة. يمكن تعيين قيمة StartUpPosition إلى واحدة من أربع إعدادات. يمكنك استخدام الإعدادات التالية لـ StartUpPosition: Manual: لا يوجد إعداد أولي محدد. CenterOwner: يتم وضع UserForm في المركز على العنصر الذي ينتمي إليه UserForm. CenterScreen: يتم وضع UserForm في المركز على الشاشة بأكملها. WindowsDefault: يتم وضع UserForm في الزاوية اليسرى العليا من الشاشة. - يمكن تعيين خاصية StartUpPosition برمجيًا أو من نافذة الخصائص. يمكنك الرجوع إلى المصادر المذكورة أدناه لمزيد من المعلومات. رابط1 رابط2 أرجو لكم الفائدة. والسلام عليكم

حل اخر يغنيك عن كتابة الاكواد في الورقة "الورقة 1" ، ضع أسماء النماذج في العمود A وفي العمود B وقت كل نموذج ، كما هو موضح في المثال التالي: 2) قم بتشغيل هذا الماكرو: 😁 Sub View_User() Dim uForm As Object Dim i As Long Dim MyRng As Variant Dim Nameform As String On Error Resume Next MyRng = Sheets("Sheet1").Range("A2", Sheets("Sheet1").Range("B" & Rows.Count).End(3)) Application.Visible = False For i = 1 To UBound(MyRng) Nameform = MyRng(i, 1) Set uForm = CallByName(UserForms, "Add", VbMethod, Nameform) DoEvents uForm.Show 0 Application.Wait Now + TimeValue("00:00:" & MyRng(i, 2)) DoEvents Unload uForm Next Application.Visible = True On Error GoTo 0 End Sub اليك الملف للفائدة تجربة 4.xlsm

اليك اخي طريقة اسرع في حالة وجود عدد كبير من الصفوف المرحلة الكود اطول لاكن اسرع بكثير من الاول 😄يمكنك ترحيل 400 صف في 2 ثواني تقريبا Sub Copy_Reports2() '''''''''''''''''' New additions to speed up code execution '""""""""""""""""""" Dim ws As Worksheet: Set ws = Sheets("البيانات") Dim wsDest As Worksheet: Set wsDest = Worksheets("تقسيم") Dim sMsg As String, rHeaders As Range, ligne As Range, t1 As Range, t2 As Range Dim LastRow&, Titles&, Cpt&, lastCol&, col&, rngCell, r&, c As Range, Réf&, N& temps = Timer With Application .EnableEvents = False .ScreenUpdating = False End With limite = ws.Evaluate("SUM(0+(A4:A" & ws.Cells(Rows.Count, "A").End(xlUp).Row & "<>""""))") Set rHeaders = ws.Range("A1:P3") Set ligne = wsDest.[A5] wsDest.Cells.Clear For x = 4 To ws.Cells(ws.Rows.Count, "A").End(xlUp).Row If ws.Range("A" & x) <> "" Then: Rng = ws.Range("A4:P" & x) début = 1: TailleBloc = 10: décal = 0: Next Do While début <= UBound(Rng) fin = début + TailleBloc - 1: If fin > UBound(Rng) Then fin = UBound(Rng) b = Application.Index(Rng, Evaluate("Row(" & début & ":" & fin & ")"), Application.Transpose(Evaluate("Row(1:" & UBound(Rng, 2) & ")"))) If ligne = 0 Then wsDest.Range("a" & Rows.Count).End(xlUp).Offset(3).Resize(UBound(b), UBound(b, 2)) = b Else Réf = wsDest.Columns("A:A").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row wsDest.Range("A" & Réf + 6).Resize(UBound(b), UBound(b, 2)) = b End If décal = décal + UBound(Rng, 2) + 1: début = fin + 1 Loop wsDest.Activate With wsDest.Cells .HorizontalAlignment = xlCenter: .VerticalAlignment = xlCenter: ActiveWindow.ScrollRow = 1: ActiveWindow.ScrollColumn = 1 .RowHeight = 40: .Columns(10).ColumnWidth = 23: .Columns(15).ColumnWidth = 16: .Font.Size = 16: .Font.Name = "Arial" End With LastRow = wsDest.Range("A:P").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = wsDest.Range("A3 :P" & LastRow) rngCell.Borders.LineStyle = xlNone For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Cpt = 14 N = 1 For Titles = 1 To LastRow Step Cpt If wsDest.Cells(Titles, "A").Offset(5, 0) <> "" Then rHeaders.Copy wsDest.Cells(Titles, 1).Cells(1).PasteSpecial xlPasteAllUsingSourceTheme, , False, False Set t1 = wsDest.Cells(Titles, "B").Offset(13, 0) Set t2 = wsDest.Cells(Titles, "C").Offset(13, 0) t1.Interior.Color = RGB(204, 255, 255): t1.Value = " رقم القائمة" t2.Value = N: t2.Interior.Color = RGB(204, 255, 255) Titles = Titles + 1 N = N + 1 End If Next Titles Application.CutCopyMode = False With wsDest For i = 3 To LastRow On Error Resume Next If wsDest.Cells(i, "M") Like "الكمية المحتسبة" And wsDest.Cells(i, "M").Offset(10, 0) <> "" Then 'تلوين الخلفية wsDest.Cells(i, "j").Offset(11, 0).Resize(, 7).Interior.Color = vbYellow: wsDest.Cells(i, "J").Offset(11, 0).Value = "المجموع" wsDest.Cells(i, "M").Interior.Color = vbYellow: wsDest.Cells(i, "O").Interior.Color = vbYellow 'الكمية المحتسبة wsDest.Cells(i, "M").Offset(11, 0) = WorksheetFunction.Sum _ (Range(Cells(i, "M").Offset(1, 0), Cells(i, "M").Offset(10, 0))) 'المبلغ الكلي wsDest.Cells(i, "O").Offset(11, 0) = WorksheetFunction.Sum _ (Range(Cells(i, "O").Offset(1, 0), Cells(i, "O").Offset(10, 0))) ' النقص wsDest.Cells(i, "P").Offset(11, 0) = WorksheetFunction.Sum _ (Range(Cells(i, "P").Offset(1, 0), Cells(i, "P").Offset(10, 0))) End If Next i [A3].Select End With On Error GoTo 0 sMsg = " تم ترحيل" & " " & limite & " مستند " & " " & "بنجاح" MsgBox sMsg & vbCrLf & vbCrLf & " " & " " & "تم تنفيد الكود في: " & Format(Timer - temps, "0.0000"), Exclamation, "اوفيسنا" With Application .EnableEvents = True .ScreenUpdating = True End With End Sub اضافة رقم القائمة 2.xlsm

أبسط هذه الطرق استعمال دالة image =IMAGE("https://quickchart.io/qr?size=100&text="&A2) خيث A2 هي الخلية التي بها النص المراد تحويله ولمن ليس لديه دالة image يمكن استخدام هذه الدالة المعرفة Function masqr(mytext As String) Dim URL As String, myrng As Range, myshp As Shape Set myrng = Application.Caller URL = "https://quickchart.io/qr?size=100&text=" & mytext On Error Resume Next ActiveSheet.Pictures("myqr" & myrng.Address(False, False)).Delete ActiveSheet.Pictures.Insert(URL).Select Set myshp = Selection.ShapeRange.Item(1) myshp.Placement = xlMoveAndSize With myshp .LockAspectRatio = msoFalse .Name = "myqr" & myrng.Address(False, False) .Left = myrng.Left .Top = myrng.Top End With masqr = "" End Function وطريقة استخدامها =masqr(A2) بالتوفيق

وعليكم السلام- باركود IDAutomationHC39M Idautomationhc39m.zip

هذه مجموعة من الخطوط يمكنك تحميلها وتثبيتها في ويندوز واستعمالها في الاكسل أو الاكسس أو اي برنامج من برامج ميكروسوفت Code 128 Code 39 UPC-E QR Postnet UPC/ EAN I2of5 Intelligent Mail بالتوفيق

نعم اخي يمكنك دالك بتعطيل هدا الصف فقط f.UsedRange = f.UsedRange.Value رغم انني عند كتابة الكود لاحظت ان الفكرة ربما لم كانت على يوزرفورم سوف تكون مميزة (لانني دائما عند الاشتغال على اي ملف اطمح الى تقديم الافضل رغم عدم طلبه ) لهدا قررت بعدما طلبت مني التعديل بانشاءه ربما يساعدك على الاشتغال على الملف بشكل افضل مع البقاء على الكود الاول ليبقى لك اختيار ما يناسبك طبعا اليك شرح الكود الاول ربما تحتاج يوما الا تعديل شيء ما Sub Créer_des_feuilles() Dim rng As Range, dico As Range, Cell As Range Dim arr(1 To 2) As String, f As Worksheet ' رسالة تنبيه عند كتابة اسم غير موجود على المصنف arr(1) = "المرجوا التحقق من إسم ورقة العمل" ' رسالة بنجاح النسخ تتظمن اسماء الاوراق الجديدة arr(2) = "تم نسخ اوراق العمل بنجاح" On Error GoTo Errorhandling NameWS = InputBox("أدخل إسم ورقة العمل المراد نسخها ", " نسخ ورقة العمل") ' التحقق من اسم ورقة العمل المراد نسخها If Evaluate("ISREF('" & NameWS & "'!A1)") Then Set rng = Application.InputBox(Prompt:=" حدد نطاق أسماء أوراق العمل: ", _ Title:="تسمية أوراق العمل", _ Default:=Selection.Address, Type:=8) For Each dico In rng ' تجاهل الفراغات اثناء التحديد If dico <> Empty Then Application.ScreenUpdating = False ' التحقق من وجود اسم الشيت مسبقا على المصنف If Not Evaluate("ISREF('" & dico & "'!A1)") Then Sheets(NameWS).Copy after:=ActiveWorkbook.Sheets(Worksheets.Count) Set f = ActiveSheet 'تسمية اوراق العمل f.Name = dico ' حدف الازرار f.DrawingObjects.Delete 'التحويل الى قيم ' f.UsedRange = f.UsedRange.Value ' تخزين اسماء الشيتات الجديدة For Each Cell In dico ws = ws & vbCrLf & Cell.Value Next Cell End If End If Next dico Application.ScreenUpdating = True MsgBox arr(2) & vbCrLf & ws, vbOKOnly, "تعليمات:" Else MsgBox arr(1), vbCritical, "إنتباه:" End If Errorhandling: End Sub تفضل اخي في انتظارك بعد تجربة الملف وسوف نكون سعداء دائما بمساعدتك Create-Sheets_User.xlsb

يمكنك استعمال هذه المعادلة في K2 ونسخها كما تشاء =SUMPRODUCT(SUBTOTAL(3,OFFSET($A$7:$A$29,ROW($A$7:$A$29)-MIN(ROW($A$7:$A$29)),,1))*($B$7:$M$29=J2)) وفقنا الله جميعا لكل خير

وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد محمد صالح اليك حلول اخرى =INDEX($B$2:$D$6, MATCH(A10,$A$2:$A$6,0), MATCH(B10, $B$1:$D$1, 0)) او =HLOOKUP(I12,$H$1:$K$6,MATCH(H12,$H$1:$H$6,0),0) اوفيسنا.xlsx

يمكنك استعمال هذه المعادلة للحصول على الرقم الأول =MID(A2,1,FIND("°",A2)-1) وهذه للرقم الثاني =MID(A2,FIND("°",A2)+2,FIND("'",A2)-FIND("°",A2)-2) وبعد دراسة هاتين المعادلتين يمكنك التوصل للرقم الثالث بالتوفيق

Sub test1() Dim WS As Worksheet: Set WS = ActiveSheet '<<<---- Worksheets("27-10-2023الى2-11-2023") 'اسم ورقة العمل Dim lastrow As Long, ligne As Range, search As Rang Set ligne = [U4] '<<<----' خلية اللصق Set search = [L19] '<<<-- اي القيمة التي تم جلبها من الخلية '<<<---اول تاريخ على الجدول ("A4") ' '("U")' تحديد اخر خلية بها بيانات من عمود lastrow = WS.Cells(Rows.Count, 23).End(xlUp).Row + 1 ' لمنع التكرار '*********************** '("U") 'التحقق من وجود نفس تاريخ المدفوعات مسبقا في عمود ' ' في حالة وجوده يتم ايقاف تنفيد الكود مع رسالة اشعار If Application.WorksheetFunction.CountIf(WS.Range("U:U"), search) > 0 Then MsgBox " يوجد نفس الفترة في المدفوعات " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub A = [L19:Q51].Value ''<<<----'نطاق البيانات المرحلة If ligne = 0 Then ' '<<<----التحقق من عدم وجود قيمة في خلية اللصق ' U4'في حالة فراغها يتم لصق البيانات ابتداءا من الخلية [U4].Resize(UBound(A), UBound(A, 2)).Value2 = A Else ' U ' في حالةوجودقيمة يتم لصق البيانات بعد اخر صف به بيانات من عمود Range("U" & lastrow).Resize(UBound(A), UBound(A, 2)).Value2 = A End If MsgBox "تم ترحيل مدفوعات" & " " & search & " " & "بنجاح", vbInformation End Sub

يمكنك استعمال هذه المعادلة في الخلية D4 =IFERROR(IF(INDEX(البصمات!$F:$F,MATCH($C$1&$B4,البصمات!$A:$A,0))="","",INDEX(البصمات!$F:$F,MATCH($C$1&$B4,البصمات!$A:$A,0))),"") وهي تعني إذا كانت نتيجة البحث فراغ تكون الخلية فارغة وليست صفرا ويمكنك تعديل معادلة الخلية E4 بنفس الطريقة بالتوفيق

السلام عليكم حسب ما فهمت من الملف المرفق من قيبل السيد sabah2023 هناك سوء فهم بتعبير الصفحة لذلك اقترح الكود التالي Sub test() Dim i& For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row Step 27 Rows(i & ":" & i + 1).RowHeight = 30 Rows(i + 2 & ":" & i + 26).RowHeight = 20 Next End Sub

وعليكم السلام ورحمة الله تعالى وبركاته في حالة الرغبة في استخدام الاكواد يمكنك تجربة المرفق التالي date3.xlsb

اليك حل اخر بعد اظافة معادلة الاخ محمد صالح Sub Test2() Set d = CreateObject("Scripting.Dictionary") k = Range("b2:D" & [b65000].End(xlUp).Row) Dim Rng(): ReDim Rng(1 To UBound(k), 1 To UBound(k, 2)) For i = LBound(k) To UBound(k) Réf = k(i, 1) & "|" & k(i, 2) & "|" & k(i, 3) If d.exists(Réf) Then lig = d(Réf) Else d(Réf) = d.Count + 5: lig = d.Count: Rng(lig, 1) = k(i, 1): Rng(lig, 2) = k(i, 2): Rng(lig, 3) = k(i, 3) End If Next i [j2].Resize(d.Count, UBound(Rng, 2)) = Rng End Sub نقل الاسماء بدون تكرار بشروط.xlsb

تفضل جرب Sub test() Dim i As Integer i = 2 For Each sh In ThisWorkbook.Worksheets Select Case sh.Name Case Is = "Sheet1", "Sheet2", "Sheet3", "Sheet7" '<----- 'تجاهل الاوراق التالية Case Else Application.ScreenUpdating = False ActiveWorkbook.Sheets("Sheet1").Hyperlinks.Add _ Anchor:=ActiveWorkbook.Sheets("Sheet1").Cells(i, 1), _ Address:="", _ SubAddress:="'" & sh.Name & "'!A1", _ TextToDisplay:=sh.Name sh.Hyperlinks.Add Anchor:=sh.Range("E1"), Address:="", SubAddress:="Sheet1" & "!A1", TextToDisplay:="رجوع" sh.Range("E1").Font.Size = 30: sh.Rows(1).AutoFit i = i + 1 End Select Next sh Application.ScreenUpdating = True End Sub ارتباط تشعبي.xlsm

Sub test() Dim a Dim i& a = Range(Cells(2, 6), Cells(2, 6).End(xlDown)).Cells With CreateObject("scripting.dictionary") For i = 1 To UBound(a) If Not .exists(a(i, 1)) Then .Add a(i, 1), a(i, 1) Next For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row If Not .exists((Cells(i, 9).Value)) Then Cells(i, 9).Interior.Color = vbRed Else Cells(i, 9).Interior.Color = xlNone End If Next End With End Sub --------------------- Sub tes2() Dim a Dim i& With CreateObject("scripting.dictionary") For i = 1 To Cells(Rows.Count, 6).End(xlUp).Row If Not .exists(Cells(i, 6).Value) Then .Add Cells(i, 6).Value, "" Next For i = 2 To Cells(Rows.Count, 9).End(xlUp).Row If Not .exists((Cells(i, 9).Value)) Then Cells(i, 9).Interior.Color = vbYellow Else Cells(i, 9).Interior.Color = xlNone End If Next End With End Sub ماكرو عادي يتم تنفيذه من قبلك

وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب اخي Sub FindCouleur() Dim j(1 To 2) As String, F As Variant Dim a As Range, R As Range, T&, Cpt&, lCol&, lrow& Dim WS As Worksheet: Set WS = Worksheets("0") Application.ScreenUpdating = False lrow = WS.Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row lCol = WS.Cells(1, Columns.Count).End(xlToLeft).Column j(1) = [Al14]: j(2) = [Al15] Set a = WS. _ Range("A1", WS.Cells(lrow, lCol)) F = Array(j(1), j(2)) With a .Interior.ColorIndex = xlNone For Cpt = LBound(F) To UBound(F) Set R = .Cells(.Cells.Count) For T = 1 To WorksheetFunction.CountIf(a, F(Cpt)) Set R = .Cells.Find(What:=F(Cpt), LookIn:=xlValues, LookAt:=xlWhole, _ After:=R, MatchCase:=False) R.Interior.Color = vbYellow Next T Next End With Application.ScreenUpdating = True End Sub أرقام.xlsm

وعليكم السلام ورحمه الله وبركاته تفضل اخي هانى Unique.xlsb

يمكنك تجربة هذه الدالة المعرفة Function FILTER_AK(Where, Criteria, Optional If_Empty) As Variant Dim Data, Result Dim i As Long, j As Long, k As Long 'Create space for the output (same size as input cells) With Application.Caller i = .Rows.Count j = .Columns.Count End With 'Clear ReDim Result(1 To i, 1 To j) For i = 1 To UBound(Result) For j = 1 To UBound(Result, 2) Result(i, j) = "" Next Next 'Count the rows to show For i = 1 To UBound(Criteria) If Criteria(i, 1) Then j = j + 1 Next 'Empty? If j < 1 Then If IsMissing(If_Empty) Then Result(1, 1) = CVErr(xlErrNull) Else Result(1, 1) = If_Empty End If GoTo ExitPoint End If 'Get all data Data = Where.Value 'Copy the rows to show For i = 1 To UBound(Data) If Criteria(i, 1) Then k = k + 1 For j = 1 To UBound(Data, 2) Result(k, j) = Data(i, j) Next End If Next 'Return the result ExitPoint: FILTER_AK = Result End Function استخدامها مثل الدالة filter في اوفيس 365 مع فارق الضغط على Ctrl+shift+enter بالتوفيق

بدايةً هذه فكرة للتحقق ما اذا كان الاسم من 3 مقاطع أو لأ في الزرار ( Be Sure ) في نموذج الاعدادات الخاص بك ، وانتي طبقيها حسب رغبتك . lab2.accdb

ابشر أخي @abood2626 بسويلك طلبك لكن بيأخذ وقت غالباً باكر يكون جاهز .

يمكنك استعمال هذه المعادلة في الخلية G19 مع سحبها لأسفل =IF(D19="","",VLOOKUP($B$2,المقسطون!$B$27:$N$62,6,0)) بالتوفيق

برنامج طباعة الاختبارات تعديل نهائي.rar

السلام عليكم و رحمة الله توجد مشاركة بتاريخ سابق تم استخدام مشابه لملفك تقريبا و بنسبة كبيرة و لكن الملف القديم كان اكثر تنظيما من الملف الحالى و لكنى سأرسل اليك الملف المشابه ربما يتوفق تماما مع طلبك هذا و الله ولى التوفيق اليك الملف الطلاب اقل من 65.xlsm

حسب فهمي للمطلوب يمكنك استعمال هذه المعادلة في الخلية AE5 مع نسخها يسارا =IF(AE4="","", IF(AE4>30,if(COUNTIF($AE$4:AE4,">"&30)=1,25%,if(COUNTIF($AE$4:AE4,">"&30)=2,50%,if(COUNTIF($AE$4:AE4,">"&30)=3,75%,100%))), IF(AE4>15,if(COUNTIF($AE$4:AE4,">"&15)=1,10%,if(COUNTIF($AE$4:AE4,">"&15)=2,15%,if(COUNTIF($AE$4:AE4,">"&15)=3,25%,50%))), if(COUNTIF($AE$4:AE4,"<="&15)=1,5%,if(COUNTIF($AE$4:AE4,"<="&15)=2,10%,if(COUNTIF($AE$4:AE4,"<="&15)=3,20%,20%))) ))) مع تغيير تنسيق الخلايا لهذا الصف نسبة مئوية percentage بالتوفيق

عليكم السلام ورحمة الله وبركاته إذا كان المقصود عدد أيام المكافأة فيمكنك حسابها بهذه المعادلة =IF(C7/360>5,75+(CEILING(C7/360,1)-5)*30,CEILING(C7/360,1)*15) وإذا كان المقصود حساب مكافأة هذه الأيام بناء على راتب الشهر المكتوب يمكنك استعمال هذه المعادلة =IF(C7/360>5,75+(CEILING(C7/360,1)-5)*30,CEILING(C7/360,1)*15)*C3/30 بالتوفيق

^_^ سبقتني لكن احب ان اضيف مشاركه مع اخي @Foksh تفضل هل هذا ما تريد 1234.rar ولتعم الفائدة وتضويح ما تم تم استخدام هذا الكود Sub GetInfo1() Dim db As DAO.Database Dim rst As DAO.Recordset Set db = CurrentDb Set rst = db.OpenRecordset("Sale_Reg", dbOpenDynaset) With rst .AddNew ![Sale_code] = DLookup("code", "main_itemn", "code=" & "Sale_code") ![Sale_Number] = 1 ![Sale_invoice] = Forms![Sale]![Invoice_Number] ![SSale_Price] = DLookup("Slae_price", "main_itemn", "code=" & "Sale_code") ![Sale_Date] = DLookup("Reg_Date", "main_itemn", "code=" & "Sale_code") ![Sale_Item_Name] = DLookup("item", "main_itemn", "code=" & "Sale_code") ![frosh_date] = Date ![scompany_name] = DLookup("company_name", "qry1", "code=" & "Sale_code") .Update .Close End With Set rst = Nothing db.Close Set db = Nothing End Sub مع ان هناك حلول اخري لكن وجدت الاسهل والاسرع للحلول دون تغير (او فرض راي) على المبرمج

قم بنسخ الأداة إلى مجلد C:\WINDOWS\SysWOW64 ثم افتح Command Prompt كمسؤول وقم بتسجيل الأداة regsvr32 RotateLabelVer2.ocx والآن يمكنك في برنامج إضافة الأداة ستظهر الأداة بهذا الاسم: يمكنك تعديل نوع الخط والحجم واللون من صندوق الخصائص RotateLabelVer2.zip

Private Sub Worksheet_Change(ByVal Target As Range) Set a = Range("F2:F" & [F65000].End(xlUp).Row) Set b = Range("I2:I" & [I65000].End(xlUp).Row + 10) Set rng1 = CreateObject("Scripting.Dictionary") Set rng2 = CreateObject("Scripting.Dictionary") If Target.Column <> 6 And Target.Column <> 9 Then Exit Sub For Each J In a rng1(J.Value) = J.Value Next J For Each J In b rng2(J.Value) = J.Value If Not rng1.exists(J.Value) And rng2(J.Value) <> "" Then J.Interior.ColorIndex = 36 If rng1.exists(J.Value) Or rng2(J.Value) = "" Then J.Interior.ColorIndex = xlNone Next J End Sub test.xlsb

عليكم السلام ربما يكون هذا المطلوب بالتوفيق نسبة المبيعات.xlsx