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

تسلم ايدك اخي الكريم @kkhalifa1960

جزاك الله خيرا و اعطاك اخي الكريم تقبل تحياتي الكبيرة

وعليكم السلام ورحمة الله تعالى وبركاته جرب هل هدا ما تقصده Const Main As String = "الرئيسية " Sub destination(WSname As String) Dim WS As Worksheet, f As Worksheet, srcWS As Worksheet Set srcWS = Sheets(Main) Application.ScreenUpdating = False For Each WS In ThisWorkbook.Worksheets If WS.Name = WSname Then Set f = WS Exit For End If Next WS On Error Resume Next For Each WS In ThisWorkbook.Worksheets If WS.Name <> WSname Then WS.Visible = xlSheetVeryHidden Next WS On Error GoTo 0 f.Visible = xlSheetVisible: f.Activate If srcWS.Visible = xlSheetVisible And WSname <> Main Then srcWS.Visible = xlSheetVeryHidden Application.ScreenUpdating = True End Sub Sub GoToMainSheet() Sheets(Main).Visible = xlSheetVisible destination Main End Sub Sub GoToPage1() destination "كشف التلامي الحاضرين صفحة 1" End Sub Sub GoToPage2() destination "كشف التلامي الحاضرين صفحة 2" End Sub Sub GoToPage3() destination "الدخول و الخروج خلال الشهر" End Sub Sub GoToPage4() destination "المعلومات العامة" End Sub وفي حدث ThisWorkbook Private Sub Workbook_Open() Dim WS As Worksheet Const srcWS As String = "الرئيسية " For Each WS In ThisWorkbook.Worksheets WS.Visible = IIf(WS.Name = srcWS, xlSheetVisible, xlSheetHidden) Next WS End Sub كشف التلاميذ الحاضرين 2023--2024.xlsb

ابو جودي .. خطر على بالي (محذور) وأنا اتصور او اتخيل مشروعك .. لديك الكثير من الواجهات وقاعدة الجداول واحدة كل واجهة لها جزء من هذه الجداول وقد تشترك اكثر من جهة في جدول واحد المحذور هو ان فورم الاستيراد يجلب جميع الجداول .. وهذا يحتوي على ثغرة امنية بمعنى قد يوجد في الجداول شيء خاص لا يجب ان يطلع عليه الا مستخدم وفرعية معينة ................ انت في هذه الحالة يجب ان يقتصر الجلب على جداول الواجهة الفعلية فقط .. وليس كل الجداول اعتقد انت تطرقت لهذه الفكرة حين قلت يرتبط بالجداول المسجلة في جدول النظام .. اعتقد كذا صح ان يكون العمل محكم من جميع الجوانب مطلب مهم

آه منك .. انت فاهم .. وعارف ان الطريق مغلق وسوف اعود اليك مسألة الليبل اشتغل تمام ولكن فيه عيب رسمي وهو انه يفرغ البيانات بعد غلق النموذج لذا رجعت واخذت بفكرتك : صحيح ان الحال عندي يكفيها اسم الجدول فقط ، ولكني ايضا اضفت قاعدة البيانات المصدر اعتقد حتى لك .. ظهور اسم الجدول وقاعدته المصدر كافية وتختصر الكثير من الوقت والجهد في مثالك وهديتك الجميلة : عملت فورم صغير يحتوي على زر مهمته نسخ اسماء الجداول المرتبطة وقواعدها الى جدول النظام ( هذا الفورم يخص المبرمج فقط) واضفت زر في فورم ربط الجداول يعرض رسالة بالجداول المرتبطة وقواعد بياناتها المرفق يحتوي على ملفين المثال السابق وقاعدة للجداول Downloads.rar

تفضل استاذ @سامر محمود المرفق بعد التعديل . ووافني بالرد . serching-3.rar

Sub Remplissez_jours_dates() Dim début As Date, DateFin As Date, CrDate As Date Dim tmp As Long, DayArr As Variant, i As Long Dim WS As Worksheet: Set WS = Sheets("البنين") If WS.Range("K2").Value = "" Or WS.Range("O2").Value = "" Or _ Not IsDate(WS.Range("K2").Value) Or Not IsDate(WS.Range("O2").Value) Or _ WS.Range("K2").Value > WS.Range("O2").Value Then MsgBox "يرجى التأكد من صحة التواريخ " & vbCrLf & _ "وتاريخ البدء لا يكون أكبر من تاريخ الانتهاء", vbExclamation Exit Sub End If début = WS.Range("K2").Value DateFin = WS.Range("O2").Value ' لاخر اسم في عمود b Dim LastRow As Long LastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row 'لاخر الكشف الصف 45 ' LastRow = 45 Application.ScreenUpdating = False WS.Range("D4:AH5").ClearContents With WS.Range("D4:AH45") .Interior.Pattern = xlNone .Font.Color = RGB(0, 0, 0) End With DayArr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت") tmp = 4 CrDate = début Do While CrDate <= DateFin If tmp > 34 Then Exit Do WS.Cells(4, tmp).Value = DayArr(Weekday(CrDate, vbSunday) - 1) WS.Cells(5, tmp).Value = CrDate If Weekday(CrDate, vbSunday) >= 6 Then WS.Range(WS.Cells(4, tmp), WS.Cells(LastRow, tmp)).Interior.Color = RGB(255, 255, 0) WS.Range(WS.Cells(4, tmp), WS.Cells(5, tmp)).Font.Color = RGB(255, 0, 0) End If tmp = tmp + 1 CrDate = CrDate + 1 Loop Application.ScreenUpdating = True End Sub جدول الحصص الإضافية 2.xlsb

السلام عليكم ورحمة الله وبركاته أخ محمد هشام نسخت الكود وعمله ممتاز . لكن هناك إشكالية أن اليوم الأول من الفترة مكرر جدول الحصص الإضافية.xlsb

début = WS.Range("K2").Value DateFin = WS.Range("O2").Value Set Rng = WS.Range("D4:AH5") If début > DateFin Then : MsgBox "لا يمكن أن يكون تاريخ البدء أكبر من تاريخ الانتهاء", vbExclamation :Exit Sub Application.ScreenUpdating = False With Rng .ClearContents .Interior.ColorIndex = xlNone End With DayArr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس", "الجمعة", "السبت") tmp = 4 CrDate = début Do While CrDate <= DateFin If tmp > 34 Then Exit Do WS.Cells(4, tmp).Value = DayArr(Weekday(CrDate, vbSunday) - 1) WS.Cells(5, tmp).Value = CrDate If Weekday(CrDate, vbSunday) >= 6 Then WS.Cells(4, tmp).Interior.Color = RGB(255, 255, 0) WS.Cells(5, tmp).Interior.Color = RGB(255, 255, 0) End If tmp = tmp + 1 CrDate = CrDate + 1 Loop Application.ScreenUpdating = True جدول الحصص الإضافية.xlsb

تفضل أخي تم تعديل الكود السابق وإظافة إمكانية تحديد الأعمدة المرحلة والمرحل إليها لتتمكن من تعديله بما يناسبك لاحقا Option Explicit Dim tmp As Variant Const tmpCol As String = "G" Private Sub Worksheet_Change(ByVal Target As Range) Dim arr(3) As Worksheet, OnRng As Range, Irow As Long, ling As Variant Set arr(0) = Sheets("بطاقة صنف"): Set arr(1) = Sheets("اضافة") Set arr(2) = Sheets("الصرف"): Set arr(3) = Sheets("الأصناف") If Not Intersect(Target, Me.Range("J2:I3")) Is Nothing Then SetApp False Set OnRng = arr(0).Range("B6:I" & arr(0).Rows.Count) OnRng.ClearContents Irow = arr(3).Cells(arr(3).Rows.Count, 1).End(xlUp).Row Me.Range("I3").Formula = "=IFERROR(VLOOKUP($J$2,'الأصناف'!$A$3:$B$" & Irow & ",2,0),"""")" Me.Range("I3").Value = Me.Range("I3").Value ling = Me.Range("I3").Value If Not IsEmpty(ling) And ling <> "" Then tmp = ling Call Cnt(arr(1), arr(0), ling, Array(4, 9, 10, 14, 16), Array(3, 5, 6, 4, 2)) Call Cnt(arr(2), arr(0), ling, Array(4, 19, 17, 9, 10, 11), Array(3, 2, 4, 7, 8, 9)) Else OnRng.ClearContents GoTo AppTrue End If AppTrue: SetApp True End If End Sub '"""""""""""""""""""""""""""""""""""" Private Sub Cnt(ByVal dest As Worksheet, ByVal tbl As Worksheet, _ ByVal temp As Variant, ByVal Colky As Variant, ByVal DestCols As Variant) Dim i As Long, x As Long, LastRow As Long, n As Long, Cel As Range, début As Long, fin As Long LastRow = dest.Cells(dest.Rows.Count, tmpCol).End(xlUp).Row début = 3 fin = LastRow For i = début To fin With dest If Not IsEmpty(.Cells(i, tmpCol).Value) And Not IsError(.Cells(i, tmpCol).Value) Then If .Cells(i, tmpCol).Value = temp Then x = WorksheetFunction.CountA(tbl.Range("B6:B1000")) For n = LBound(Colky) To UBound(Colky) Set Cel = tbl.Cells(6 + x, DestCols(n)) Cel.Value = .Cells(i, Colky(n)).Value Next n End If End If End With Next i End Sub '""""""""""""""""""""""""""""" Private Sub SetApp(ByVal Enable As Boolean) Application.ScreenUpdating = Enable Application.EnableEvents = Enable Application.Calculation = IIf(Enable, xlCalculationAutomatic, xlCalculationManual) End Sub مخازن 2024مكرو v3.xlsm

• البحث عن كلمة أولها (ال) وآخرها (تنوين): <ال[! ]@[ًٌٍ]> • كلمة أولها (ال) وآخرها (ون) ليس بعدها (فتحة): ال[! ]@(ون)[!َ]> • البحث عن أي كلمة أو رمز، أو رقم: <[! ]*> • البحث عن أي كلمة، وهي تصلح في عمل الماكرو: <[أ-ىيئءؤءاإًٌٍَُِّْ]@> • أو: <[أ-يًٌٍَُِّْ]@> • البحث عن أي كلمة: <[أ-ي]@> • البحث عن أي كلمة: <[! ]@> يكتب قبلها كلمة عند البحث والاستبدال لأنها تبطئ الماكرو، وربما تهنج الورد. • البحث عن أي كلمتين: <[! ]@> <[! ]@> • البحث عن أي كلمتين الأولى تبدأ بهمزة، والثانية تنتهي بتاء مربوطة: <أ[! ]@> <[! ]@ة> • البحث عن أي كلمتين الأولى آخرها ألف، والثانية تنتهي بالألف: <[! ]@ا> <[! ]@ا> • البحث عن كلمتين متتاليتين مكررتين: (<* ){2} ، ويمكن البحث بـ{3، 4} أو <([أؤئإءيا-ى]@)> \1> • البحث عن كلمتين، أو عددين، أو جملتين متتاليتين مكررتين بينهما فاصلة: (<*>)، \1 • البحث عن جملتين متتاليتين مكررتين: (<*>) \1 • ولحذف الكلمة أو الجملة المكررة نضع في مربع الاستبدال: \1 • البحث عن حرفين أو رقمين متتاليين متطابقين: (?){2} • البحث عن أي كلمتين أو حرفين أو رقمين متتاليين متطابقين: (<*){2} • البحث عن آخر كلمة في الخلية (تنفع للشعر): <[أ-ىيئءؤءاإًٌٍَُِّْ]@>[! ء-ى] • البحث عن أي رقمين متتاليين بينهما فاصلة مثل 22، 22، ويمكن بـ{3، 4}: (<*){2}، (<*){2} • البحث عن أي رقمين متتاليين بينهما فاصلة، وليس قبلهما سلاش: [!\/]<[0-9]@>، <[0-9]@>[!\/] • البحث عن أي رقمين متتاليين بينهما فاصلة، الثاني ليس قبله سلاش: <[0-9]@>، <[0-9]@>[!\/] • البحث عن فقرة وتظليلها: (*^13) • البحث عن فقرتين متتاليتين متطابقتين: (*^13)\1 • البحث عن ثلاث فقرات متتالية متطابقة: (*^13)\1\1 • البحث عن فقرة قبلها فقرة فارغة وبعدها فقرة فارغة: ^13{2}([!^13]@^13)^13 • البحث عن فقرة قبلها فقرة فارغة: ^13{2}([!^13]@^13) • البحث عن فقرة قبلها أو بعدها فقرة فارغة: ^13{2}([!^13]@) • ولحذف هاتين الفقرتين الفارغتين ضع في خانة الاستبدال: ^p<H1>\1 • البحث عن الفقرات المكررة بشكل متتالي: (*^13)(\1)@ • البحث عن فقرة عن طريق حروف البدل: ^13 • البحث عن فقرة قبلها أي حرف عن طريق حروف البدل: >^13 ، وبعدم اعتبار المسافة آخر الفقرة: >^13* • البحث عن أي فقرة إلى كلمة (في) مثلا للتظليل: <[! ]*في> • البحث عن فقرة ليس في نهايتها (.) أو (:) أو (؟) أو (!): ([!^13.:\؟\!\-\!]^13) • تحديد ما بين الفاصلتين: ، <[! ]*>، • تحديد ما بين كلمتين مثل: عن <[! ]*> عن • البحث عن أي كلمة مكونة من حرفين: <[! ]@{2}> • البحث عن أي كلمة مكونة من حرفين آخرها تنوين: <[! ]@{2}[!ًٌٍ]> البحث عن كلمة خمس حروف ليس منها علامات الضبط: <[! ]@{5}[ًٌٍَُِّْ]> • للبحث عما بين قوسين هلاليين: (\(*)\) أو \(?@\) • للبحث عما بين معقوفين: \[?@\] • للبحث عن أي رقم دون الحروف: [0???-9] • للبحث عن أي رقم فردي أو زوجي أو أكثر: <[0-9]@> • لتظليل رقم بعده سلاش (شرطة مائلة/) حتى آخر الفقرة: <[0-9]@>/*^13 • للبحث عن رقم واحد: <[0-9]{1}> أو رقمين: <[0-9]{2}> وهكذا بزيادة رقم بين {} • للبحث عن أي كلمة دون الأرقام: <[أ-ى][! ]@> • للبحث عن أي رقمين بينهما فاصلة: [0???-9]، [0???-9] • للبحث عن الأرقام بين سلاشين شرطتين مائلتين //: /[!ء-ي]*/ • للبحث عن أي رقم حتى نهاية الفقرة: [0-9]*^13 • للبحث عن الحروف والأرقام دون المسافات وعلامات الترقيم: [أ-ي0-9] • لتحديد ما بين شرطتين مائلتين: / [???0-9]*/ • البحث عن الحاشية السفلية مع حروف البدل: ^2 • البحث عن قوس مربع [ ليس له قوس غلق ] : \[[!\]]@^13 • البحث عن قوس هلالي ( ليس له قوس غلق ) : \([!\)]@^13 • البحث عن قوس مدبب ( ليس له قوس غلق ) : \«[!\»]@^13 • البحث عن قوس مرعوش ( ليس له قوس غلق ) : \{[!\}]@^13 • لجعل علامة الحاشية بين قوسين: في مربع بحث اكتب الآتي ^f وفي مربع استبدال اكتب (^&) وهذا الكود يعني أن المكتوب في خانة البحث يساوي المكتوب في خانة الاستبدال، فيمكن استخدامه مع أي حرف وأي رقم، حيث الاستبدال لا ينفع مع أي حرف وأي رقم، لكن بإضافة هذا الكود يصبح الاستبدال متاحا. • للبحث عن أي رقم بعده صفر (0) بعده سلاش (/) على صورة (08/): 0^#/ الوظيفة مثال يبحث عن ؟ أي حرف فردي ك؟ن "كان" و"كون" و"كمن". * أي سلسلة من الأحرف ك*ب "كتاب" و"كتيب". [ ] أحد الأحرف المحددة د[ي و]ن "دين" و"دون". [-] أي حرف فردي في هذا النطاق "[بس]عد "بعد" و"سعد". وليس و"رعد" يجب أن تكون النطاقات ضمن ترتيب تصاعدي [!] أي حرف فردي باستثناء الحرف داخل الأقواس ح[!م]ل "حقل" و"حفل" وليس "حمل". [!د-ك] أي حرف فردي باستثناء الأحرف .. ت[!دك]وين "تموين" و"تلوين" وليس عن "تدوين"، أو "تكوين". {2} الكلمات التي يتكرر فيها الحرف أو التعبير السابق للأقواس تماما معل{2}ة عن "معللة" وليس "معلة". الكلمات التي يتكرر فيها الحرف أو التعبير السابق للأقواس مرة على الأقل معل{1;}ة "معلة" و"معللة". الكلمات التي يتكرر فيها الحرف أو التعبير السابق للأقواس من " كذا " إلى " كذا " عدد من المرات 10{1;3} "10" و"100" و"1000". @ تكرار واحد أو أكثر للحرف أو التعبير السابق معل@ة "معللة". <(حرف أو أكثر) بداية الكلمة "<(قا)*" "قائل" و"قاتل" وليس عن "مقاتل". (حرف أو أكثر)> نهاية الكلمة "*(صل)>" "فاصل" و"واصل" وليس عن "واصلة". استخدم الأقواس لتجميع أحرف البدل والنص في تعبير واحد <(اخ)*(ار)> "اختصار" و"اختبار". وليس احتضار للبحث عن أحرف البدل كما لو أنها أحرُف، اكتب الخط المائل العكسي (\) \؟ ؟

وعليكم السَّلام عَلَيكُم وَرَحمَةُ الله وَبَرَكَاتُه - قم بفتح مربع البحث والاستبدال بالضغط على ctrl+H - في خانة البحث قم بكتابة ^ متبوعة بحرف f صغير - في خانة الاستبدال قم بكتابة علامتي ^ ثم & وتضعهما بين قوسين ثم اضغط استبدال ستوضع جميع الأرقام في المتن أو الحواشي داخل قوسين

جرب هذا الملف OSOL3 salim.xls