اذهب الي المحتوي
أوفيسنا

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

  1. أ / محمد صالح

    أ / محمد صالح

    أوفيسنا


    • نقاط

      202

    • Posts

      4,357


  2. محمد هشام.

    محمد هشام.

    الخبراء


    • نقاط

      127

    • Posts

      853


  3. Foksh

    Foksh

    الخبراء


    • نقاط

      80

    • Posts

      629


  4. عمر ضاحى

    عمر ضاحى

    الخبراء


    • نقاط

      70

    • Posts

      982


Popular Content

Showing content with the highest reputation since 03 نوف, 2023 in all areas

  1. هذه طريقتي في إعادة تسمية العناصر الكثيرة دفعة واحدة في النموذج بأسماء متسلسلة مثل : ( Box2 , Box1 , ... ) هو كود وقد عملت له نموذج لتسهيل العمل .. 🙂 الكود يقوم أيضا بترتيب وتنسيق العناصر في شكل منتظم لتسهيل عملية التصميم 😊 إقرأ الملاحظات جيدا قبل أن تطبق 😉👌🏻 النموذج : النتيجة ستكون هكذ : ( من >>>> إلى ) >>>> >>>> للاستفادة من هذا النموذج .. قم بنقل النموذج لقاعدة البيانات عندك وسيتعرف تلقائيا على النماذج التي عندك 🙂 ملف التحميل : إعادة تسمية العناصر مع الترتيب بواجهة مرنة.accdb
    11 points
  2. برنامج طباعة الاختبارات بطريقة الاتمته (الاصدار الثاني) برمجة وتصميم الاستاذ صالح احمد محمد ربيع هذا البرنامج اهداء لجميع المدارس برنامج طباعة الاختبارات الاصدار ٢.xls
    7 points
  3. اخي سعد صفحة المطور ليس لها علاقة بملف او مصنف معين.هي إعدادات خاصة بنسخة الأوفيس. يتم تحديدها من طرفك بالشكل الذي تريد. ربما وبدون قصد تم حذف او إضافة نافذة معينة أو شيء من هذا القبيل من المطور واصبح بشكل انت غير متعود عليه. كما سميتها انت باللخبطة. اسهل طريقة بالنسبة لك هي إعادة نسخة الأوفيس للوضع الافتراضي
    6 points
  4. بعد إذن أخينا الفاضل محمد هشام هذا الكود بنفس طريقتك 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 رغم أني أعتقد كان من السهل على حضرتك عمل التعديل إن كنت حضرتك صاحب الكود أما إن كنت استخدمت كود غيرك فمن الواضح أنك لم تقم بمدارسته وفهمه بالتوفيق
    6 points
  5. السلام عليكم بناءا على طلب بعض الاخوة اقدم لكم برنامج صغير لارشفة الصور برنامج ارشفه.accdb
    5 points
  6. تم تعديل البرنامج مع اضافة الباركود اسفل الورقة. *ملاحظة هامة* يتم تثبيت خطوط الباركود المرفقه مع البرنامج لكي يظهر الباركود بصورة صحيحة اسفل ورقة الاختبار برنامج طباعة الاختبارات تعديل نهائي٣.rar
    5 points
  7. السلام عليكم و رحمة الله اليك شرح الكود المطلوب ارجو ان اكون قد وفقت 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
    5 points
  8. يمكنك استعمال هذه الدالة المعرفة 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) وبعد استعمالها تعامل مثل الدوال الموجودة في الاكسل من حيث تحديث بيانات الخلية مباشرة بدون الضغط على زر للتحديث بالتوفيق
    5 points
  9. يمكنك تجربة هذه المعادلة =MID(A2,FIND("|AR|",A2)+4,100) بالتوفيق
    5 points
  10. وعليكم السلام 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
    5 points
  11. استكمالا لجهود الزملاء الأعزاء إذا كان لديك أوفيس 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),"") بالتوفيق للجميع
    5 points
  12. عليكم السلام إذا كنت منفتحاً على استخدام ماكرو فإليك هذا وإلا .... 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
    5 points
  13. 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
    5 points
  14. بالاذن من الاستاذ محمد هشام. طريقة أخرى 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
    4 points
  15. الأخوة الأفاضل: السلام عليكم وجدت هذا الموقع بالصدفة وبه مجموعة من الأكواد والشروحات لعل البعض يستفيد منها . https://www.isladogs.co.uk/code-samples/index.html
    4 points
  16. السلام عليكم ورحمة الله نعالى وبركاته بعد ادن الاستاد أ / محمد صالح بالنسبة لاظهار بيانات اليوم فقط تفضل جرب اخي 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
    4 points
  17. السلام عليكم ورحمة الله وبركاته وبها نبدأ من فترة كبيرة لم أدخل المنتدى وبالفعل أشتاق اليكم يشرفني ان ارفع شرح أحد الأفكار البسيطة كنت قد قدمتها وهي بالفعل نقطة في بحر القائمين على المنتدى
    4 points
  18. إذا كان المطلوب أن يعمل الكود في حدث التغيير في جميع الشيتات فيجب وضع الكود في هذا المصنف 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 بالتوفيق
    4 points
  19. السلام عليكم أخي الكريم طرحت سؤالك على برنامج دردشة ميكروسوفت فكان الجواب كالتالي: يتم استخدام خاصية StartUpPosition في إكسل لتحديد موقع ظهور UserForm عندما يتم فتحه لأول مرة. يمكن تعيين قيمة StartUpPosition إلى واحدة من أربع إعدادات. يمكنك استخدام الإعدادات التالية لـ StartUpPosition: Manual: لا يوجد إعداد أولي محدد. CenterOwner: يتم وضع UserForm في المركز على العنصر الذي ينتمي إليه UserForm. CenterScreen: يتم وضع UserForm في المركز على الشاشة بأكملها. WindowsDefault: يتم وضع UserForm في الزاوية اليسرى العليا من الشاشة. - يمكن تعيين خاصية StartUpPosition برمجيًا أو من نافذة الخصائص. يمكنك الرجوع إلى المصادر المذكورة أدناه لمزيد من المعلومات. رابط1 رابط2 أرجو لكم الفائدة. والسلام عليكم
    4 points
  20. حل اخر يغنيك عن كتابة الاكواد في الورقة "الورقة 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
    4 points
  21. اليك اخي طريقة اسرع في حالة وجود عدد كبير من الصفوف المرحلة الكود اطول لاكن اسرع بكثير من الاول 😄يمكنك ترحيل 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
    4 points
  22. أبسط هذه الطرق استعمال دالة 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) بالتوفيق
    4 points
  23. وعليكم السلام- باركود IDAutomationHC39M Idautomationhc39m.zip
    4 points
  24. هذه مجموعة من الخطوط يمكنك تحميلها وتثبيتها في ويندوز واستعمالها في الاكسل أو الاكسس أو اي برنامج من برامج ميكروسوفت Code 128 Code 39 UPC-E QR Postnet UPC/ EAN I2of5 Intelligent Mail بالتوفيق
    4 points
  25. نعم اخي يمكنك دالك بتعطيل هدا الصف فقط 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
    4 points
  26. يمكنك استعمال هذه المعادلة في 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)) وفقنا الله جميعا لكل خير
    4 points
  27. وعليكم السلام ورحمة الله تعالى وبركاته بعد ادن الاستاد محمد صالح اليك حلول اخرى =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
    4 points
  28. يمكنك استعمال هذه المعادلة للحصول على الرقم الأول =MID(A2,1,FIND("°",A2)-1) وهذه للرقم الثاني =MID(A2,FIND("°",A2)+2,FIND("'",A2)-FIND("°",A2)-2) وبعد دراسة هاتين المعادلتين يمكنك التوصل للرقم الثالث بالتوفيق
    4 points
  29. 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
    4 points
  30. يمكنك استعمال هذه المعادلة في الخلية D4 =IFERROR(IF(INDEX(البصمات!$F:$F,MATCH($C$1&$B4,البصمات!$A:$A,0))="","",INDEX(البصمات!$F:$F,MATCH($C$1&$B4,البصمات!$A:$A,0))),"") وهي تعني إذا كانت نتيجة البحث فراغ تكون الخلية فارغة وليست صفرا ويمكنك تعديل معادلة الخلية E4 بنفس الطريقة بالتوفيق
    4 points
  31. السلام عليكم حسب ما فهمت من الملف المرفق من قيبل السيد 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
    4 points
  32. وعليكم السلام ورحمة الله تعالى وبركاته في حالة الرغبة في استخدام الاكواد يمكنك تجربة المرفق التالي date3.xlsb
    4 points
  33. اليك حل اخر بعد اظافة معادلة الاخ محمد صالح 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
    4 points
  34. تفضل جرب 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
    4 points
  35. 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 ماكرو عادي يتم تنفيذه من قبلك
    4 points
  36. وعليكم السلام ورحمة الله تعالى وبركاته تفضل جرب اخي 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
    3 points
  37. وعليكم السلام ورحمه الله وبركاته تفضل اخي هانى Unique.xlsb
    3 points
  38. يمكنك تجربة هذه الدالة المعرفة 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 points
  39. بدايةً هذه فكرة للتحقق ما اذا كان الاسم من 3 مقاطع أو لأ في الزرار ( Be Sure ) في نموذج الاعدادات الخاص بك ، وانتي طبقيها حسب رغبتك . lab2.accdb
    3 points
  40. ابشر أخي @abood2626 بسويلك طلبك لكن بيأخذ وقت غالباً باكر يكون جاهز .
    3 points
  41. يمكنك استعمال هذه المعادلة في الخلية G19 مع سحبها لأسفل =IF(D19="","",VLOOKUP($B$2,المقسطون!$B$27:$N$62,6,0)) بالتوفيق
    3 points
  42. السلام عليكم و رحمة الله توجد مشاركة بتاريخ سابق تم استخدام مشابه لملفك تقريبا و بنسبة كبيرة و لكن الملف القديم كان اكثر تنظيما من الملف الحالى و لكنى سأرسل اليك الملف المشابه ربما يتوفق تماما مع طلبك هذا و الله ولى التوفيق اليك الملف الطلاب اقل من 65.xlsm
    3 points
  43. حسب فهمي للمطلوب يمكنك استعمال هذه المعادلة في الخلية 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 بالتوفيق
    3 points
  44. عليكم السلام ورحمة الله وبركاته إذا كان المقصود عدد أيام المكافأة فيمكنك حسابها بهذه المعادلة =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 بالتوفيق
    3 points
  45. ^_^ سبقتني لكن احب ان اضيف مشاركه مع اخي @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 مع ان هناك حلول اخري لكن وجدت الاسهل والاسرع للحلول دون تغير (او فرض راي) على المبرمج
    3 points
  46. قم بنسخ الأداة إلى مجلد C:\WINDOWS\SysWOW64 ثم افتح Command Prompt كمسؤول وقم بتسجيل الأداة regsvr32 RotateLabelVer2.ocx والآن يمكنك في برنامج إضافة الأداة ستظهر الأداة بهذا الاسم: يمكنك تعديل نوع الخط والحجم واللون من صندوق الخصائص RotateLabelVer2.zip
    3 points
  47. 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
    3 points
  48. عليكم السلام ربما يكون هذا المطلوب بالتوفيق نسبة المبيعات.xlsx
    3 points
×
×
  • اضف...

Important Information