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

ضع المجلد في سي قد يروق لكم العمل Registeration book.zip

وعليكم السلام ورحمة الله تعالى وبركاته ضع الكود التالي في Module Sub HideRowsWith_Zero() Dim Sh As Worksheet Dim i As Long, lastRow As Long Set Sh = ThisWorkbook.Sheets("تفاصيل") lastRow = Sh.Columns("A:C").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row For i = 4 To lastRow If Sh.Cells(i, 2).Value = 0 And Sh.Cells(i, 3).Value = 0 Then Sh.Rows(i).Hidden = True Else Sh.Rows(i).Hidden = False End If Next i End Sub وفي حدث ورقة تفاصيل Private Sub Worksheet_Activate() HideRowsWith_Zero End Sub اخفاء الصفوف.xlsb

وعليكم السلام ورحمة الله وبركاته على ما يبدو ان المشكلة تكمن في تنسيق التاريخ UPDATE fordate SET fordate.ada = DSum("pamounts", "amanat", "pdate<=#" & Format([ta], "dd/mm/yyyy") & "#"); جرب هذا الاستعلام

تفضل اخي جرب هدا الاقتراح حاول اولا ترتيب عناصر التيكست بوكس على اليوزرفورم بشكل متتابع وفي وحدة class module ضع الكود التالي مع تسميته مثلا ب Officena كما في الصورة ادناه Public WithEvents MultTextbox As MSForms.TextBox Private Sub MultTextbox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If TypeOf MultTextbox Is MSForms.TextBox Then Select Case KeyCode Case 37 ' السهم اليسار SendKeys "+{TAB}" Case 39 ' السهم اليمين SendKeys "{TAB}" Case Else ' السماح لجميع المفاتيح الأخرى بالعمل بشكل طبيعي Exit Sub End Select End If End Sub Private Sub MultTextbox_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) Dim ctrl As MSForms.Control Dim isTextBox As Boolean isTextBox = TypeOf MultTextbox Is MSForms.TextBox If isTextBox Then With USERFORM1 '<<======== 'قم بتعديل الاسم الى اسم النمودج الخاص بك For Each ctrl In .Controls ' التحقق من أن العنصر هو TextBox If TypeOf ctrl Is MSForms.TextBox Then ctrl.BackColor = RGB(255, 255, 255) 'ابيض كافتراضي' لون الخلفية End If Next MultTextbox.BackColor = RGB(255, 255, 128) ' تغيير لون الخلفية للأصفر عند التركيز End With End If End Sub وفي داخل اليوزرفورم ضع الكود التالي Dim i As Integer Dim ctrl As Control Dim TxtBx() As New Officena Private Sub UserForm_Initialize() Dim i As Long, ctrl As MSForms.Control i = 1 For Each ctrl In Me.Controls If TypeName(ctrl) = "TextBox" Then ReDim Preserve TxtBx(i) Set TxtBx(i).MultTextbox = ctrl i = i + 1 End If Next End Sub تفضل اليك المرفقات للتجربة User_Move left and right.rar

السلام عليكم ورحمة الله تعالى وبركاته • هدية اليوم هى منتقى التواريخ تم الانتهاء من البرمجة والتطوير بالتعاون مع الاستاذ @Moosak ابداع وروعة وجمال تنسيق التصميم قام به اخى الحبيب و استاذى الجليل الاستاذ @Moosak كل الشكر والتقدير والامتنان على تعبه وحرصه على ان يخرج التطبيق بهذه الافكار الى النور فى ابهى صورة بهذا الشكل مميزات التطبيق وجود جدولين الجدول الاول : tblHolidaySettings هذا الجدول وظيفته هى التأشير على ايام العطلات الاسبوعية تبعا للمؤسسة وبذلك يتم تلوين ايام العطلات لتكون مميزة باللون الاحمر وهذا مثال لاختيار يوميى الجمعة والسبت الجدول الثانى : هذا الجدول وظيفتة اضافة تواريخ العطلات الرسمية للدولة و وصف العطلة عند الانتهاء من تسجيل كل العطلات الرسمية للدولة فى الجدول وبعد فتح منتقى التواريخ تبعا لكل شهر تظهر قائمة بالاعياد والمناسبات الرسمية ويتم تغيير لون خلفية اليوم ليكون معروفا من خلال النظر انه عطلة رسمية وبمجرد التحرك من الاسهم فى لوحة المفاتيح للمرور على الايام او اختيار اليوم بضغطة زر واحدة من الفأرة يتم ظهور وصف العطلة الرسمية فى اسفل مربعات الايام كما بالشكل التالى لاختار اليوم اما بالنقر مرتين على رقم اليوم او تحريك علامة الدائرة الزرقاء لتحديد اليوم من خلال ازرار الاسهم من لوحة المقاتيح ثم الضغط على زر اختيار والموجود بالاسفل يسار النموذج زر الامر المسمى اليوم الحالى ينقل فورا الدائرة الزرقاء الى رقم اليوم الذى يوافق تاريخ اليوم يمكن تغيير اتجاه ترتيب الارقام لتبدأ من اليمين الى اليسار او العكس من خلال الزر الموجود بجوار زر اليوم الحالى : ⇋ طريقة استدعاء الدالة لتعمل مع اى مربع نص يستخدم لادخال و كتابة التواريخ تكون كالاتى عمل زر امر بجوار مربع النص وفى منشئ التعبير لحدث النقر لهذا الزر يتم استدعاء الدالة بالشكل التالى على ان يتم تغير الوصف و اسم مربع النص تبعا لاغراض التصميم =CalendarFor([اسم مربع النص فى النموذج],"اكتب الوصف الدال على مربع نص التاريخ :") ملاحظة الوصف الذى سوف يتم كتابته اثناء استدعاء الدالة سوف يطهر فى اعلى يمين النموذج تحت زر الامر الغاء وان كان مربع النص الخاص بالتاريخ يحتوى بالفع على تاريخ سوف تجد هذا التاريخ ايضا تحت هذا الوصف وشرح الوظائف المختلفة للازرار من لوحة المفاتيح التى يمكن التعامل معها بسهولة موجود فى الزر اعلى اليسار " ؟ " اتمنى لكم تجربة شيقة واتمنى ان اكون قدمت اليكم شيئا عمليا ويعود عليكم بالنفع تم اضافة اصدار جديد لتنقيح وتفادى بعض الاخطاء بتاريخ 22/09/2024 - ضبط اسهم زيادة او نقصان الشهور والسنوات تبعا لترتيب واجهة ترتيب التواريخ ( يمين / يسار ) - ضبط الفتح التلقائى لقائمة السنوات او الشهور لاغلاقها اذا كانت مفتوحة بدلا من اعادة فتح القائمة مرة اخرى عند تكرارا الضغط رقم الاصدار الجديد 4 Handler - calendar (V3).zip Handler - calendar (V4).accdb

السلام عليكم ورحمة الله وبركاته في المثال المرفق يوجد نموذج اسمه البحث الشامل ويوجد فيه مربع نص اسمه (txtSearch) لكتابة كلمات البحث وفيه الحدث التالي عند التغيير Dim vSearchString As String vSearchString = Me.txtSearch.Text Me.txtSearch2.Value = vSearchString Me.SearchList.Requery Me.Requery عندما تكون البيانات قليله فان الكتابه فيه تكون سريعه وممتازة ولكن القاعده عندي في العمل فيها سجلات كثيرة جداً وعندما اكتب كلمات للبحث سواء نص او ارقام فأنه بطيئ جدا جدا مثال لو ادخلت اسم محمد من اجل البحث عن كل من اسمه محمد فانه يكتب م وانتظر شويه حتى يلحقه ح ثم شويه ويلحقه م وهكذا المطلوب جزاكم كل خير اذا فيه كود بدال الكود اعلاه حتى تكون الكتابه في الحقل سريعه او اي طريقه تشوفها لي لانه والله جنني وما لقيت له حل اتمنى اكون قدرت اوصل لكم ماذا اريد كل الشكر والتقدير المثال.rar

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

رفعت لك مثالك بدون رايت كلك وبدون شيفت ... هو انت اللي عاملها والمفروض انك تقدر تعطلها . الشيء المهم : لابد ادخل في راسك وأقرأ افكارك من اجل اعرف انت عايز تعرض ايه في التقرير .. فالمرفق فقط جداول وانت ذكرت في اول موضوعك اني انا صممت لك تقرير خاص وتريد مشابه له طيب التقرير اللي ذكرته من وين تفتح وتعرض التقرير ؟ اليس من نموذج ؟ وهذا النموذج يحتوي على حقول نختار منها من اجل نعرضها في التقرير ؟ ستقول نعم صح .. طيب اريدك تعمل لي هذا النموذج وداخله الحقول المراد عرضها . اقتبست لك ردي السابق .. هل هو واضح ومفهوم ؟ DATA14 (2).rar

كود جميل استاذنا ولا اروع ما رأيك لو الحدث قبل التحديث هل يكون أقوى ؟

جرب هذا واعلمنا بالنتيجة ............. Private Sub genu_AfterUpdate() Dim fieldValue As String fieldValue = Me.genu.Value ' Check if the field value starts with "17" If Left(fieldValue, 2) = "17" Then MsgBox "ادخال خاطئ! يجب ألا يبدأ الحقل بالرقم 17." Me.genu.Undo ' Undo the input End If End Sub

برنامج متعوب عليه شكر وتقدير واحترام من اخيك

قم بتطبيق العلاقات كما هو موضح هنا وعند الانتهاء ننتقل الى انشاء نماذج الادخال

وعليكم السلام ورحمة الله تعالى وبركاته جرب اخي الصيغة التالية '=IFERROR(INDEX(Feuil1!B$2:B$200, AGGREGATE(15, 6, ROW(Feuil1!$B$2:$B$200) / ($F$3=Feuil1!$A$2:$A$200), ROW(Feuil2!D1))-1), "") او =IFERROR(INDEX(Feuil1!B$2:B$200,SMALL(IF($F$3=Feuil1!$A$2:$A$200,ROW(Feuil1!$B$2:$B$200)-1),ROW(Feuil2!D1))),"") recherche 1.xlsx

اخي الفاضل مربع inputbox في Excel لا يدعم إخفاء كلمة السر أو إظهارها كنجوم أو علامات. هو ببساطة يعرض مربع حوار لإدخال النص دون تقديم خيارات لتنسيق العرض مثل إخفاء النص. لإخفاء كلمة السر أو إظهارها كنجوم، يجب عليك استخدام Userform الذي يتيح لك تخصيص واجهة المستخدم بشكل أكبر. يمكنك استخدام خاصية PasswordChar لمربع النص (Textbox) لعرض كلمات المرور كنجوم أو أي رمز آخر تختاره بعد معاينة الكود الخاص بك حاولت تجربة انشاء شاشة دخول بسيطة بنفس الفكرة مع اظافة بعض التحسينات على الكود وطريقة اشتغالك على الملف مع اظافة ورقة خاصة بتسجيل الزوار باسم AccessLog لتتبع المستخدمين والمدة المستغرقة في استخدام الملف هدا مجرد اقتراح بسيط للفائدة فقط اليك الكود مع الشرح لتتمكن من تعديله بما يناسبك Private Sub UserForm_Initialize() Set f = Sheets("list") Set MonDico = CreateObject("Scripting.Dictionary") ' قراءة القيم من العمود L، بدءًا من الخلية L2 حتى آخر خلية بها بيانات a = f.Range("l2:l" & f.[L65000].End(xlUp).Row).Value For i = LBound(a) To UBound(a) ' إضافة القيم غير الفارغة إلى Dictionary (القيم الفريدة فقط) If a(i, 1) <> "" Then MonDico(a(i, 1)) = "" Next i Me.ComboBox1.List = MonDico.keys End Sub Private Sub CommandButton1_Click() Dim ws As Worksheet, logWs As Worksheet Dim lrow As Long, clé As String Dim password As String, Xtime As String Static AttemptCount As Integer, username As String ' تعيين ورقة العمل "list" Set ws = ThisWorkbook.Sheets("list") ' تعيين ورقة العمل للتسجيل Set logWs = ThisWorkbook.Sheets("AccessLog") ' الحصول على اسم المستخدم من ComboBox username = ComboBox1.Value ' التحقق إذا كان اسم المستخدم مدخل If username = "" Then MsgBox "يرجى اختيار اسم المستخدم.", vbExclamation Exit Sub End If ' العثور على آخر صف يحتوي على بيانات في العمود 12 (L) lrow = ws.Cells(ws.Rows.Count, 12).End(xlUp).Row ' البحث عن كلمة السر المرتبطة بالاسم For i = 2 To lrow If ws.Cells(i, 12).Value = username Then password = ws.Cells(i, 13).Value Exit For End If Next i ' الحصول على كلمة السر المدخلة من مربع النص clé = TextBox1.Text ' التحقق إذا كانت كلمة السر المدخلة صحيحة If clé = password Then ' تسجيل الدخول الناجح With logWs ' العثور على آخر صف فارغ في الأعمدة A, B, C و D lrow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1 .Cells(lrow, 1).Value = username .Cells(lrow, 2).Value = Date .Cells(lrow, 3).Value = Format(Time, "hh:mm:ss") ' توقيت الدخول فقط كوقت .Cells(lrow, 4).Value = "دخول ناجح" ' إضافة رسالة تسجيل الدخول الناجح End With ' عرض رسالة ترحيب MsgBox "مرحبا " & username & "، لقد تم تسجيل الدخول بنجاح!", vbInformation ' إظهار Excel Application.Visible = True ' إغلاق UserForm Unload Me ' إعادة تعيين عدد المحاولات AttemptCount = 0 Else ' معالجة الدخول الفاشل AttemptCount = AttemptCount + 1 If AttemptCount >= 3 Then MsgBox "لقد تجاوزت عدد المحاولات المسموح بها. سيتم حفظ وإغلاق الملف.", vbExclamation ThisWorkbook.Save Application.Quit Else MsgBox "الرجاء التأكد من كلمة السر! المحاولة " & AttemptCount & " من 3" Me.TextBox1.Text = "" End If End If End Sub Private Sub CommandButtonClose_Click() Dim answer As VbMsgBoxResult answer = MsgBox("هل أنت متأكد من الخروج من البرنامج؟", vbYesNo + vbQuestion, "تأكيد الإغلاق") If answer = vbYes Then ' حفظ المصنف ThisWorkbook.Save ' إغلاق المصنف ThisWorkbook.Close SaveChanges:=False Application.Quit End If End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then Cancel = True MsgBox "يرجى استخدام زر الإغلاق المخصص لإغلاق النموذج", vbInformation End If End Sub وفي حدث ThisWorkbook Private Sub Workbook_Open() Application.Visible = False UserForm1.Show End Sub '**************************************** Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim logWs As Worksheet Dim lrow As Long Dim currentTime As Date Dim entryTime As Date On Error Resume Next Set logWs = ThisWorkbook.Sheets("AccessLog") If logWs Is Nothing Then MsgBox "ورقة العمل 'AccessLog' غير موجودة.", vbExclamation Exit Sub End If ' الحصول على الوقت الحالي currentTime = Now ' العثور على آخر صف يحتوي على بيانات lrow = logWs.Cells(logWs.Rows.Count, 1).End(xlUp).Row ' التحقق إذا كان هناك سجل سابق لتوقيت الدخول If lrow > 1 Then ' الحصول على توقيت الدخول entryTime = logWs.Cells(lrow, 3).Value ' تسجيل توقيت الخروج With logWs .Cells(lrow, 4).Value = Format(currentTime, "hh:mm:ss") ' توقيت الخروج فقط كوقت End With End If On Error GoTo 0 ' إلغاء التعامل مع الأخطاء ' حفظ المصنف ThisWorkbook.Save ' إغلاق المصنف ThisWorkbook.Close SaveChanges:=False ' تأكد من إغلاق المصنف بشكل صحيح ' إذا كنت تريد إغلاق Excel بالكامل، استخدم: 'Application.Quit End Sub عند الانتهاء من تعديل برنامجك حاول وضع باسوورد لمحرر الاكواد تفاديا للتلاعب بها كلمات المرور واسماء المستخدمين الحالية كما في الصورة فوق بالتوفيق.... شاشة دخول.xlsb

نعم راق لي عمل جميل ولكن ملاحظتي على التنسيق والالوان غير مريحة لعين الشخص الذي سيعمل على هذا المشروع :: تحياتي

لا اعلم مادا تقصد هل كيفية ادراج الكود او كيفية تطبيقه على ملفات اخرى الاولى لايمكنني شرحها يمكنك البحث عنها ستجدها صوة وصورة اما الاحتمال الثاني وهو الارجح على ما اعتقد لكي تطبق الكود على ملفات اخرى لابد ان تفهمه اولا لتتمكن من تعديله بما يناسبك سأقوم بمحاولة اظافة بعض التعليقات المهمة للتوضيح Sub Collection_of_books_Sheet1() '****"RS_ST_196"' هذا الماكرو يقوم بتجميع أسماء الطلاب والكتب من ورقة ' ويقوم بنسخها إلى ورقة1 مع حساب عدد الكتب لكل طالب Dim WS As Worksheet, dest As Worksheet Dim lastRow As Long, i As Long Dim studentName As String, bookName As String, n As String Dim bookNumber As Variant, row As Range, lr As Long Dim startRow As Long, ling As Long, bCount As Integer Dim rngCell As Range Application.ScreenUpdating = False '***** تحديد أوراق العمل Set WS = ThisWorkbook.Sheets("RS_ST_196") Set dest = ThisWorkbook.Sheets("Sheet1") '******** "RS_ST_196" ,ورقة ' تحديد آخر صف في العمود AK lastRow = WS.Cells(WS.Rows.Count, "AK").End(xlUp).row With dest.Range("A2:C" & dest.Cells(dest.Rows.Count, "A").End(xlUp).row) .ClearContents ' مسح جميع البيانات في النطاق .ClearFormats ' مسح جميع التنسيقات في النطاق End With ling = 2 ' بدء الكتابة من الصف 2 في ورقة "Sheet1" ' حلقة لتمرير جميع الصفوف في ورقة المصدر من الصف 18 إلى آخر صف مستخدم For i = 18 To lastRow ' التحقق مما إذا كان الصف مخفيًا (إذا لم يكن مخفيًا، يتم معالجة الصف) If Not WS.Rows(i).Hidden Then ' الحصول على اسم الطالب من العمود "AK" studentName = WS.Cells(i, "AK").Value ' التحقق مما إذا كان اسم الطالب يبدأ بـ "اسم الطالب: " If InStr(studentName, "اسم الطالب: ") = 1 Then ' إزالة "اسم الطالب: " من بداية النص للحصول على الاسم الفعلي للطالب studentName = Trim(Mid(studentName, Len("اسم الطالب: ") + 1)) n = "" ' لتجميع أسماء الكتب bCount = 0 ' عداد للكتب startRow = i + 2 ' البدء من الصف الذي يليه للتحقق من الكتب ' حلقة لتمرير جميع الكتب المرتبطة بالطالب Do While WS.Cells(startRow, "AB").Value <> "" bookName = WS.Cells(startRow, "AB").Value bookNumber = WS.Cells(startRow, "AN").Value '(عمود التسلسل م) التأكد من أن الكتاب ليس مجرد عنوان عمود وأن رقم الكتاب غير فارغ If WS.Cells(startRow, "AB").Value <> "اسم المقرر" And Not IsEmpty(bookNumber) Then ' تجميع أسماء الكتب في متغير n If n = "" Then n = bookName Else n = n & " + " & bookName End If bCount = bCount + 1 ' زيادة عدد الكتب لكل طالب End If startRow = startRow + 1 ' الانتقال إلى الصف التالي Loop '** نسخ النتائج ' كتابة اسم الطالب، أسماء الكتب المجتمعة، وعدد الكتب في ورقة الوجهة dest.Cells(ling, "A").Value = studentName ' اسم الطالب dest.Cells(ling, "B").Value = n ' أسماء الكتب dest.Cells(ling, "C").Value = bCount ' عدد الكتب ling = ling + 1 ' الانتقال إلى الصف التالي لكتابة بيانات الطالب التالي End If End If Next i '** تحديد آخر صف مستخدم في الاعمدة A:C "Sheet1" lr = dest.Range("A:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row Set rngCell = dest.Range("A2:C" & lr) '** تنسيق الخلايا في النطاق المحدد With rngCell .Font.Bold = True ' تنسيق الخط .MergeCells = False ' التأكد من عدم دمج الخلايا .HorizontalAlignment = xlCenter ' ضبط المحاذاة الأفقية إلى الوسط .VerticalAlignment = xlCenter ' ضبط المحاذاة الرأسية إلى الوسط .WrapText = True ' تفعيل التفاف النص ' ضبط ارتفاع الصفوف إلى 35 For Each row In .Rows row.RowHeight = 35 Next row End With '** إضافة حدود للخلايا في النطاق For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Application.ScreenUpdating = True MsgBox "تم تجميع أسماء الطلاب والكتب بنجاح", vbInformation End Sub

من خصائص User form أفعل كما هو موضح بالصورة و ضع نجمة مقابل passwordChar

تفضل اخي تم انشاء الكود لتنفيد طلبك بادن الله يكفي الظغط علر زر إزالة العلامات الزائدة 🤔 Sub Remove_additional_Tags() Dim WS As Worksheet, i As Long, _ OneRng As Range, cell As Range, _ CntText As String, tmp As String, _ rCount As Long Set WS = ThisWorkbook.Sheets("ورقة2") Set OneRng = WS.Range("B7:B" & WS.Cells(WS.Rows.Count, "B").End(xlUp).Row) Application.ScreenUpdating = False rCount = 0 For Each cell In OneRng CntText = cell.Value tmp = "" ' ****حساب عدد العلامات الأصلية***** Dim originalPlusCount As Long, newPlusCount As Long originalPlusCount = Len(CntText) - Len(Replace(CntText, "+", "")) ' *****إزالة علامات "+" المتتالية أو غير الضرورية****** Dim src As String src = Trim(CntText) Do While InStr(src, " + +") > 0 src = Replace(src, " + +", " + ") Loop If Left(src, 2) = " + " Then src = Mid(src, 3) End If If Right(src, 2) = " + " Then src = Left(src, Len(src) - 2) End If ' ****إزالة أي علامة "+" بعد آخر كلمة***** If Right(src, 1) = "+" Then src = Left(src, Len(src) - 1) End If Dim words() As String words = Split(src, " + ") For i = LBound(words) To UBound(words) If Trim(words(i)) <> "" Then If tmp <> "" Then tmp = tmp & " + " & Trim(words(i)) Else tmp = Trim(words(i)) End If End If Next i ' ****حساب عدد العلامات التي تمت إزالتها***** newPlusCount = Len(tmp) - Len(Replace(tmp, "+", "")) rCount = rCount + (originalPlusCount - newPlusCount) cell.Value = tmp Next cell Application.ScreenUpdating = True If rCount > 0 Then MsgBox "تمت إزالة" & " " & rCount & _ " علامة غير مستخدمة بنجاح ", vbInformation Else MsgBox "لا يوجد علامات زائدة", vbInformation End If End Sub RS_ST_196 V3.xls

هذا ما كنت أحاول فهمه كما سبق الذكر يمكنك ذالك بدون الاعتماد أو إظافة الارتباط التشعبي ضع الكود التالي في حدث ورقة الرئيسية Private Sub Worksheet_SelectionChange(ByVal Target As Range) Dim f As Worksheet: Set f = ThisWorkbook.Sheets("الرئيسية") Application.ScreenUpdating = False f.Range("M2:M" & f.Rows.Count).ClearContents ' تحديث العمود "M" بالنص "تفاصيل الطلب" لكل صف يحتوي على قيمة في العمود "B" For i = 2 To f.Cells(f.Rows.Count, "B").End(xlUp).Row If f.Cells(i, "B").Value <> "" Then f.Cells(i, "M").Value = "تفاصيل الطلب" ' <<=====' يمكنك تعديل النص بما يناسبك End If Next i Application.ScreenUpdating = True If Not Intersect(Target, Me.Columns("M")) Is Nothing Then Dim lr As Long, OneRng As Range Dim rCrit As String, tmp As Boolean tmp = False On Error Resume Next tmp = Not ThisWorkbook.Sheets("التفصيلية") Is Nothing On Error GoTo 0 If Not tmp Then MsgBox "ورقة العمل التفصيلية غير موجودة", vbExclamation Exit Sub End If If Target.Row > 1 Then If Me.Cells(Target.Row, "M").Value <> "" And Me.Cells(Target.Row, "B").Value <> "" Then Dim WS As Worksheet Set WS = ThisWorkbook.Sheets("التفصيلية") If WS.AutoFilterMode Then WS.AutoFilterMode = False rCrit = Me.Cells(Target.Row, "B").Value If rCrit <> "" Then lr = WS.Cells(WS.Rows.Count, "J").End(xlUp).Row Set OneRng = WS.Range("J2:J" & lr).Find(What:=rCrit, LookIn:=xlValues, LookAt:=xlWhole) If Not OneRng Is Nothing Then WS.Activate With WS.Range("B2:O" & lr) .AutoFilter 9, rCrit End With Else MsgBox "غير موجود في قاعدة البيانات" & " : " & rCrit, 16 End If End If End If End If End If End Sub طلب فلتر V3.xlsb

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

تفضل اخي جرب هدا بعد إلغاء ارتباط Combobox (PREPARATEURS) من اعدادات اليوزرفورم كما في الملف المرفق Private Sub UserForm_Initialize() Set f = Sheets("PREPARATEUR ") Set d = CreateObject("Scripting.Dictionary") a = f.Range("A2:A" & f.[A65000].End(xlUp).Row) For i = LBound(a) To UBound(a) If a(i, 1) <> "" Then d(a(i, 1)) = "" Next i Me.PREPARATEURS.List = d.keys Me.DATES.Value = Date Me.HEURS.Value = Format(Now, "hh:mm:ss") End Sub '***************************** Private Sub AJOUTER_Click() Dim tbl As ListObject Dim arr, lr As Long, lige As Range, cmb() Set tbl = Range("LISTE_DE_BL").ListObject arr = Array(DATES.Value, HEURS.Value, _ Me.BLS.Value, Me.PREPARATEURS.Value) Set lige = tbl.ListColumns(1).Range.Find(What:="*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious) lige.Offset(1).Resize(1, 4).Value = arr Me.BLS = "": Me.PREPARATEURS = "" ThisWorkbook.Save UserForm_Initialize End Sub احتمالات واردة If Me.BLS.Value = "" Then: MsgBox "Please Enter N°BL", vbCritical: BLS.SetFocus: Exit Sub If Me.PREPARATEURS.Value = "" Then _ MsgBox "Please Enter a Name PREPARATEURS", vbCritical: PREPARATEURS.SetFocus: Exit Sub 'حقل اليوم و الوقت غير قابلة للتغيير Me.DATES.Locked = True Me.HEURS.Locked = True VBA V2.xlsm

محاولتي توجد دالة بالـ vba لحساب أي مدة بالسنوات. الاجازات_01.xlsm

موقع PixVerseلادرا ج صورة وتحويلها الى فيديو واضاقة كراكتر " Image/ charater "

موقع لعمل كلمات اغانى وتلحينها وتشغيلها فورا ذكاء اصطناعي

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