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

هناك حل اخر لاثراء الموضوع . في وجهة نظري سوف يغنيك عن اظافة كل لون على حدى داخل الكود خاصة ادا قمت باظافة الوان اخرى للملف يكفي وضع اسماء الالوان المستخدمة مثلا في عمود AG وتلوين خلية العمود المجاور وليكن مثلا AH باللون المطلوب كما في الصورة اسفله واستخدام الكود التالي Sub Spinner2_Change() Dim myRange As Range, cell As Range 'نطاق البيانات Set myRange = Range("F5:F33") With Application .ScreenUpdating = False On Error Resume Next With myRange .Interior.ColorIndex = xlColorIndexNone: .Font.Color = RGB(0, 0, 0) End With For Each cell In myRange If Not IsError(.Match(cell.Value, Columns("AG"), 0)) Then ' عمود اسماء الالوان ' لون الخلفية cell.Interior.Color = Cells(.Match(cell.Value, Columns("AG"), 0), "AH").Interior.Color ' عمود الالوان ' لون الخط cell.Font.Color = Cells(.Match(cell.Value, Columns("AG"), 0), "AH").Interior.Color End If Next .ScreenUpdating = True End With On Error GoTo 0 End Sub تلوين 3.xlsm

شوفت بقى الكلام اختلف ازاى كده مش بقول لك

جرب هذا وان =IFERROR(MAXIFS($G:$G, $A:$A, $J$3, $E:$E, $J$1), "")

نعم أخي- لقد قمت بارسال ملف بدون جداول مرتبطة أخي الكريم @Foksh بعد ملاحظات : المشكلة كانت عندي وهي في إخفاء (caché) قاعدة بيانات الجداول المرتبطة : اي كانت مخفية وغير ظاهرة وأنا قمت بإخفاءها مع مجلد البرنامج ومنه لا حظت أنه إذا كانت الجداول المرتبطة مخفية يتم إنشاء ملف backup وملف التاريخ لكن بداخلهما لا يوجد شئ : وهذا في جهاز الحاسوب في مكان عملي أما في جهاز الحاسوب في البيت فكانت قاعدة بيانات الجداول المرتبطة ظاهرة وعير مخفية مما جعل الكود يشتغل عادي وبدون مشاكل أخي @Fokshبارك الله فيك على الكود وجعله في ميزان حساناتك وصدقة جارية أن شاء الله لك كما أشكر الأخ @محمد السيسي بارك الله فيكم جميعا وربي يبارك في هذا المنتدى الرائع

🌼 السلام عليكم ورحمة الله وبركاته 🌼 يسرني اليوم أن أقدم لكم الإصدار الثاني والمطور من الأداة المتميزة والرائعة ( الكاتب الذكي لدوال المجال ) . Dloockup, DCount, DMax, DMin, Dfirst, DLast هذه الأسطورة التي تقوم بكتابة دوال المجال نيابة عنك بشكل آلي .. :: ما هو الجديد :: اليوم أحتفل معكم بإصدار النسخة الثانية والمطورة لهذه الأداة والتي تتميز بالإضافات التالية : 1- إمكانية إضافة عدد لا نهائي من المعايير ( الشروط ). 2- التعرف التلقائي على نوع بيانات الحقول. 3- جلب قيمة المعيار من التقارير. 4- ميزة إضافة الأقواس حول المعايير. 5- حفظ بيانات آخر عملية قمت بها. 6- كتابة الدالة بمجرد الضغط على زر Enter. 7- تم إضافة أزرار لتسهيل كتابة الدالة NZ والمعامل Like. 8- تكبير لوحة الناتج بالضغط المزدوج عليها. 🌹🍀🌹🍀🌹 وهنا تم شرح هذه الإضافات بالتفصيل : :: شرح كيفية استخدام الأداة بالتفصيل :: :: 🌼 شكر وتقدير 🌼 :: لكل من ساهم برأي أو فكرة أو تطبيق في هذا العمل ، وجزاكم الله عن المسلمين كل خير 😊🌹 :: حمل الإصدار الثاني للكاتب الذكي لدوال المجال 2.0 :: ‏‏‏‏Domain Functions Builder V2.0.accdb

اخي قم بازاحة العمود الاول على ورقة الشيكات للحصول على عمود A فارغ ووضع المعادلة التالية مع سحبها الى الاسفل على حسب البيانات الموجودة لديك =IF(G2<>"";COUNTIF($G$2:G2;G2)&"-"&G2;"") وفي ورقة اليومية الخلية Q8 ضع المعادلة الاتية مع سحبها الى الاسفل =IFERROR(VLOOKUP(COUNTIF($A$8:A8;A8)&"-"&A8;الشيكات!$A$2:$G$1000;2;0);"") اليك الملف للتجربة استخراج رقم من البيانV2.xlsx

شكر وتقدير واحترام من اخيك

طيب بعد اذن اساتذتى ممكن اقول فكرتى المتواضعة اولا فى الجدول tabl2 اضف حقل جديد نوعه تاريخ واعطه الاسم TimeNow وفى القيمة الافتراضية للحقل من الجدول ضع Now() استخدام TOP 1 مع ORDER BY على حقل الوقت (Timenow) هو طريقة شائعة للعثور على أحدث سجل بناء على الزمن هذه الطريقة تعتبر فعالة وسريعة بالنسبة لاستخدام SELECT Max قد يكون ذلك فعالا ولكن قد يكون لديه بعض التأثيرات على الأداء في حالة كانت كمية السجلات كبيرة عموما الفرق في الأداء قد يكون غير ملحوظ في العديد من الحالات والاختيار بين الطريقتين يعتمد على الاحتياجات الدقيقة لتطبيقك يفضل اختيار الطريقة التي تفي بمتطلبات تطبيقك وتتناسب مع نمط البيانات الخاص بك في حالة استفادتك من TOP 1 مع ORDER BY يمكنك الاستمرار في استخدامها بثقة اخيرا الاستعلام يكون بالشكل الاتى: SELECT TOP 1 tabl2.id, tabl2.INAME, tabl2.sal_price, tabl2.Qty, tabl2.No_tawla, tabl2.sal_price * tabl2.Qty AS Price FROM tabl2 ORDER BY tabl2.TimeNow DESC;

=IFERROR(1/(1/MAXIFS(G3:G1000;$A3:$A1000;"="&J3;$E3:$E1000;"="&J1));"") ملف.xlsx

استخراج رقم من البيان.xlsx

عاشت ايدك اخوي الكريم بيروح مباشرة على الـدكيومنت Current Project طيب لو خصصت فولدر معين في بارتشن كيف يكون المسار هل هو بهذا الشكل ؟ filename ="D:NRc.path & \ "Aracestbl.xls" ام ماذا ؟؟؟ بصراحة حاولت التغيير لكن ما نفع معاي ارجو الافادة

أخي الكريم @ابو عبد الله العراقي استبدل هذا الكود في الزر المسؤول عن التصدير On Error GoTo com: Dim filePath As String filePath = CurrentProject.Path & "\Aracestbl.xls" DoCmd.OutputTo acOutputTable, "Aracestbl", acFormatXLS, filePath, True, , , acExportQualityPrint com: MsgBox Err.Description وهذا الملف بعد التعديل Rac.accdb

الحمد لله الذي بنعمته تتم الصالحات لا شكر على واجب، حياكم الله أخي الكريم

الدالة LOOKUP يمكنك الاطلاع على بناء الجملة بالإضافة إلى الرابط الذي أرفقه لك لتتم الاستفادة منه بإذن الله تعالى: شرح دالة Lookup للبحث واستخراج القيم والله أعلى وأعلم والسلام عليكم.

تفضل أخي محاولتي حسب مافهمت الشرح والمرفق . ووافني بالرد . DDTest.rar

بعد اذن اخي الحبيب @Foksh ممكن تجرب اضافة البيانات فى استعلام واظبط الترتيب ال تريده داخل الاستعلام هذا واجعل مصدر البيانات فى النموذج او التقرير او الاستعلام مجرد فكره

شكرا جزيلا لك استاذ محمد

استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل جزاكم الله خيــــرا على دعواتكم الطيبة اسأل الله تعالى ان يرزقكم فضلها واجرها اضعافا مضاعفة لكم كل الفضل بعد رب العزة سبحانه وتعالى انضممت اليكم ولا اعلم عن الاكسس الا اسمه فجزاكم الله خيـرا على رعايتكم بحب وتحملكم بحلم شكر الله لكم انتم وكل اساتذتى الذين اتعلم منهم واخيـــــر وليس آخرا احبكم فى الله

انتظر وان شاء الله ابشـر بالخيـر

ومن قال انه يكفينى انا ؟! ومن قال اننى فى حل اعتذر عن التأخير كنت صائم بل روعة حياتنا هم اساتذتنا العظماء الذين اناروا افكارنا شكرا لكم استاذى الجليل و معلمى القدير و والدى الحبيب استاذ @ابوخليل سعادة الحياة أن تكون بجانبك وتساندك روح طيبة وكريمة تمنحك وتهديك الفرح والسرور وتدخل على نفوس من حولها الفرح و السعادة ولا أزكيكم على الله وكل اساتذتنا المبجلين كل كلمات ومعان الشكر والعرفان بالجميل لا تكفيكم وتوفيكم قدر حقكم بارك الله لكم فى عمركم وفى علمكم و عملكم واهلكم وأسال الله تعالى لكم سعادة الدارين وان يزيدكم من فضله كما تدخلون السرور على قلوب طلاب العلم دائما تكثرون من العطاء وبكل سخاء دون كلل ولا ملل احسن الله اليكم كما تحسنون الى طلاب العلم دائما ----- اتفضل استاذى الجليل ومعلمى القدير ووالدى الحبيب اولا الدالة الاتية لاحضار اسماء الحقول Function GetFieldNameFromRowSource(ComboRowSource As String, columnIndex As Integer) As String Dim columns As Variant Dim columnName As String ' Split the RowSource to get the column names columns = Split(Mid(ComboRowSource, InStr(ComboRowSource, "SELECT") + Len("SELECT")), ",") ' Extract the column name from the specified index columnName = Trim(Split(Split(columns(columnIndex - 1), "AS")(0), ".")(1)) ' Return the column name GetFieldNameFromRowSource = columnName End Function وهذه الدالة التى يتم التحديث من خلالها Sub GetComboBoxNameAndUpdateTableRecords(frm As Form) Dim ctrl As Control Dim ComboRowSource As String Dim FldData As String Dim FldID As String Dim strSQL As String ' Loop through all controls on the form For Each ctrl In frm.Controls ' Check if the control is a TextBox or a ComboBox If TypeOf ctrl Is comboBox Then ' Perform your custom action for each control ' For example, print the name and set a default value If Not ctrl Is Nothing Then ' Debug.Print "Control Name: " & ctrl.Name ComboRowSource = ctrl.rowSource FldID = GetFieldNameFromRowSource(ComboRowSource, 1) FldData = GetFieldNameFromRowSource(ComboRowSource, 2) Dim varConditionFieldValue As Variant Dim varUpdateFieldValue As Variant ' Open the database Dim db As DAO.Database Set db = CurrentDb ' Verify RowSource If Len(ComboRowSource) = 0 Then ' Debug.Print "RowSource is empty for control " & ctrl.Name Exit For End If ' Open a recordset for the values in targetComboBox Dim rsCombo As DAO.Recordset Set rsCombo = db.OpenRecordset(ComboRowSource, dbOpenSnapshot) ' Verify Recordset If rsCombo.EOF Then ' Debug.Print "Recordset is empty for control " & ctrl.Name rsCombo.Close Set rsCombo = Nothing Set db = Nothing Exit For End If Do Until rsCombo.EOF Dim TableName As String Dim FieldToUpdate As String Dim ConditionFieldNameTable As Variant Dim ConditionComboBoxFieldNameTable As Variant ' Get the value from the current record in targetComboBox varConditionFieldValue = rsCombo.Fields(FldID).Value varUpdateFieldValue = rsCombo.Fields(FldData).Value ' Table and Field Names TableName = "Table1" FieldToUpdate = "textNm" ConditionFieldNameTable = "frmNm" ConditionComboBoxFieldNameTable = "FieldNm" ' Construct the SQL update statement strSQL = "UPDATE " & TableName & " " & _ "SET " & FieldToUpdate & "='" & Nz(varUpdateFieldValue, "") & "' " & _ "WHERE " & TableName & "." & ConditionComboBoxFieldNameTable & "= '" & ctrl.Name & "' AND " & _ TableName & "." & ConditionFieldNameTable & "= '" & Nz(frm.Name, "") & "' AND " & _ TableName & "." & FieldToUpdate & "= '" & varConditionFieldValue & "';" ' Debug.Print strSQL ' Execute the query db.Execute strSQL, dbFailOnError rsCombo.MoveNext Loop ' Close the recordset and the database rsCombo.Close Set rsCombo = Nothing Set db = Nothing End If End If Next ctrl End Sub ونستدعى الدالة فقط من خلال GetComboBoxNameAndUpdateTableRecords Me هى سوف تقوم بكل شئ بالنيابة عنك لا تقلق منها يا معلملى هى دالة ذكية ليست مثلى طبعا يا استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل ان اردت اضافة هذه المعاملات ( parameters ) الى رأس الدالة لتكتبها عند الاستدعاء ان كانت متغيرة فلا بأس بذلك سبق التعامل معها فى الامثلة السابقة ' Table and Field Names TableName = "Table1" FieldToUpdate = "textNm" ConditionFieldNameTable = "frmNm" ConditionComboBoxFieldNameTable = "FieldNm" بــــــس خلاص أخيرا خلصت الواجب الحمد لله واخيرا المرفق DatabaseUp7.rar

استاذى الجليل ومعلمى القدير و والدلى الحبيب الاستاذ @ابوخليل اعتذر انا فى العمل الان لذلك اعتذر عن التأخير فى الرد وهذا التعديل الاخير بناء على رغباتكم اتمنى ان شاء الله أن يكون ملائما ومناسبا بصراحة مش قادر اسهل التعامل مع الدالة باستدعائها باكتر من ذلك اعرف ان كود الاستدعاء اصبح كبير جدا ويحتوى على العديد من المعاملات parameters Sub UpdateTableRecordsFromComboBox(TableName As String, _ FieldToUpdate As String, _ ConditionFieldNameTable As String, _ ConditionComboBoxFieldNameTable As String, _ frm As Form, _ TargetComboBox As ComboBox, _ ConditionFieldName As String, _ UpdateValueFieldName As String) Dim db As DAO.Database Dim strSQL As String Dim varConditionFieldValue As Variant Dim varUpdateFieldValue As Variant Dim rsCombo As DAO.Recordset ' Check if the tableName is specified If Nz(TableName, "") = "" Then MsgBox "Please specify the table name.", vbExclamation Exit Sub End If ' Check if the FieldToUpdate is specified If Nz(FieldToUpdate, "") = "" Then MsgBox "Please specify the target field name to update.", vbExclamation Exit Sub End If ' Check if the targetComboBox is valid If TargetComboBox Is Nothing Then MsgBox "Please select a valid ComboBox.", vbExclamation Exit Sub End If ' Check if the conditionFieldTable is specified If Nz(ConditionFieldNameTable, "") = "" Then MsgBox "Please specify the condition field name for the table.", vbExclamation Exit Sub End If ' Check if the conditionField is specified If Nz(ConditionFieldName, "") = "" Then MsgBox "Please specify the condition field name.", vbExclamation Exit Sub End If ' Check if the updateValueField is specified If Nz(UpdateValueFieldName, "") = "" Then MsgBox "Please specify the update field name.", vbExclamation Exit Sub End If ' Check if the ConditionComboBoxFieldNameTable is specified If Nz(ConditionComboBoxFieldNameTable, "") = "" Then MsgBox "Please specify the condition ComboBox field name for the table.", vbExclamation Exit Sub End If ' Open the database Set db = CurrentDb ' Open a recordset for the values in targetComboBox Set rsCombo = db.OpenRecordset(TargetComboBox.RowSource, dbOpenSnapshot) ' Disable the error handling temporarily On Error Resume Next ' Loop through each record in targetComboBox Do Until rsCombo.EOF ' Get the value from the current record in targetComboBox varConditionFieldValue = rsCombo.Fields(ConditionFieldName).Value varUpdateFieldValue = rsCombo.Fields(UpdateValueFieldName).Value ' Construct the SQL update statement strSQL = "UPDATE " & TableName & " " & _ "SET " & FieldToUpdate & "='" & Nz(varUpdateFieldValue, "") & "' " & _ "WHERE " & TableName & "." & ConditionComboBoxFieldNameTable & "= '" & TargetComboBox.Name & "' AND " & _ TableName & "." & ConditionFieldNameTable & "= '" & Nz(frm.Name, "") & "' AND " & _ TableName & "." & FieldToUpdate & "= '" & varConditionFieldValue & "';" ' Debugging information ' Dbug.Print "SQL Statement: " & strSQL ' Execute the query db.Execute strSQL ' Check for errors If Err.Number <> 0 Then ' Clear the error Err.Clear ' Move to the next record without processing the error Resume Next End If ' Move to the next record in targetComboBox rsCombo.MoveNext Loop ' Enable the normal error handling On Error GoTo 0 ' Close the recordset and the database rsCombo.Close Set rsCombo = Nothing Set db = Nothing strSQL = vbNullString varConditionFieldValue = vbNullString varUpdateFieldValue = vbNullString End Sub المرفق.. DatabaseUp6.rar

لعدم توافر شبكة لتجربة الكود ، ولكن تفضل بتجربته هذا الكود ، وأعطاء النتيجة . Private Sub Form_BeforeUpdate(Cancel As Integer) Dim recordID As Integer Dim strSQL As String Dim rs As Recordset ' استخراج معرف السجل الحالي recordID = Me.Recordset.Fields("ID").Value ' قم بتغيير "ID" إلى اسم الحقل الخاص بمعرف السجل ' التحقق مما إذا كان هناك مستخدم آخر قد دخل إلى نفس السجل strSQL = "SELECT Count(*) AS RecordCount FROM YourTableName WHERE ID = " & recordID & " AND UserID <> " & Me.UserID Set rs = CurrentDb.OpenRecordset(strSQL) If rs.Fields("RecordCount").Value > 0 Then ' يوجد مستخدم آخر قد دخل إلى نفس السجل MsgBox "يوجد مستخدم آخر قد دخل إلى هذا السجل. لا يمكنك التحديث.", vbExclamation Cancel = True End If rs.Close Set rs = Nothing End Sub

أخي @محمد حسن المحمد ما المقصود LOOKUP(2;1

تفضل أخي محاولتي . Example20-1.rar

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

شكرا لك من اعماق قلبي @محمد حسن المحمد اسال الله يسعدك ويفتح عليك 🤩

تمام تسلم جزاكم الله خيرا

وعليكم السلام ورحمة الله وبركاته: مناداة 3.xls

وعليكم السلام ورحمة الله وبركاته أرجو أن يكون الحل مناسباً يمكنك وضع المعادلة التالية في B2 ووضع معادلة ثانية في C2 كما يلي: B2: =IF(A2="";"";VLOOKUP(A2;Table1;2;0)) C2: =IF([رقم الموظف]="";"";LOOKUP(2;1/(Table1[[الاسم ]]=[[الاسم ]]);Table1[تاريخ اخر اجازة])) بالتوفيق إن شاء الله Book144.xlsm

الموضوع تعبنى جدا والله وكان تحدى صعب احب التنويه الى شئ استخدام sleep اثناء العمل قد يصيب الأكسس بالتجميدوالشلل وقد يعلق فى الذاكرة ولذلك ابتعدت عن ضبط الاكواد من خلالها واليكم نتيجة التحدى اولا تم مراعاة وضع الاكواد فى وحدة نمطية ليتم استخدامها فى اكثر من نموذج حتى لو اختلف وتعددت الوان أزرار الأوامر ومهما اختلفت اسماء او عناوين الأزرار وفى حاجة كمان لو عاوزيين نلون لون الزرار بالاصفر بس ومنغيرش تسمية عنصر التسمية ممكن جدا جدا ومن نفس الكود يعنى كود ذكى وابن حلال وبيقدر يفهمنا من أول تكه على الزرار اه والله زيمبئولكم كده.. شغل فاخر من الاخر اومااااااااااال 1- أكواد الوحدة النمطية Option Compare Database Option Explicit ' Constant that specifies the time interval for color flashing (in seconds) Const dblTimeInterval As Double = 0.5 ' Constant that determines the number of times the colors will flash Const intFlashCount As Integer = 5 ' Variable to track whether Label flashing should occur Public AllowFlashing ' Public variables to store default values Public btnControlDefaultColor As Long Public lblControlDefaultColor As Long Public strLblControlCaption As String Public formIsClosing As Boolean ' Public variable to store the selected button Public selectedButton As CommandButton ' Function to return the highlighted color Function ApplyHighlighted() As Long ApplyHighlighted = RGB(255, 255, 0) End Function ' Subroutine to set the button color Sub ButtonColor(ByVal frm As Form, Optional btn As CommandButton = Nothing, Optional DisableLabelChange As Boolean) ' Set the default button color if not highlighted If Not btn Is Nothing Then If btn.BackColor <> ApplyHighlighted Then btnControlDefaultColor = btn.BackColor ' Clear the previous button's highlight If Not selectedButton Is Nothing Then selectedButton.BackColor = btnControlDefaultColor End If ' Set the new button as selected and highlight it btn.BackColor = ApplyHighlighted ' Save the caption of the current button If Not DisableLabelChange Then strLblControlCaption = btn.Caption End If Set selectedButton = btn End If End Sub ' Subroutine to flash the label control Sub FlashLabelControl(frm As Form, lblControl As Object, DisableLabelChange As Boolean) On Error GoTo ErrorHandler Dim flashingColor As Long Dim flashingInterval As Single Dim flashCount As Integer Dim flashTimer As Single Dim i As Integer On Error GoTo 0 ' Turn off error trapping. On Error Resume Next ' Defer error trapping. ' Set the default label color if not highlighted If lblControl.BackColor <> ApplyHighlighted Then lblControlDefaultColor = lblControl.BackColor flashingColor = ApplyHighlighted flashingInterval = dblTimeInterval flashCount = intFlashCount ' Reset the label color to the default when the form is loaded If TypeOf lblControl Is Access.Label And Not formIsClosing Then lblControl.BackColor = lblControlDefaultColor If Not DisableLabelChange Then lblControl.Caption = strLblControlCaption End If End If flashTimer = Timer + flashingInterval ' Flash the label color For i = 1 To flashCount Do While Timer < flashTimer And Not formIsClosing DoEvents Loop ' Update the label color during the flash If TypeOf lblControl Is Access.Label And Not formIsClosing Then If AllowFlashing Then ' Check the AllowLabelCaptionChange value to determine whether to change the caption If Not DisableLabelChange Then lblControl.Caption = IIf(lblControl.Caption = strLblControlCaption, strLblControlCaption, vbNullString) End If lblControl.BackColor = IIf(lblControl.BackColor = lblControlDefaultColor, flashingColor, lblControlDefaultColor) End If End If ' Update the flash timer flashTimer = Timer + flashingInterval Next i ' Reset the label color to the default after flashing If TypeOf lblControl Is Access.Label And Not formIsClosing Then lblControl.BackColor = lblControlDefaultColor If Not DisableLabelChange Then lblControl.Caption = strLblControlCaption End If End If ' 2467 Err.Clear ' Clear Err Exit Sub ' Exit to avoid handler. ErrorHandler: ' Error-handling routine. Select Case Err.Number ' Evaluate error number. Case Is = 2467 flashCount = 0 flashTimer = 0 Exit Sub ' Exit to avoid handler. Case Else ' Handle other situations here... MsgBox Err.Number & ": " & Err.Description Resume ' Resume execution at the same line End Select End Sub ' Subroutine to change the button color and control Label flashing Sub ChangeCommandButtonColor(frm As Form, Optional lblControl As Object, Optional DisableLabelChange As Boolean) On Error GoTo ErrorHandler Dim clickedButton As CommandButton Set clickedButton = frm.ActiveControl On Error GoTo 0 ' Turn off error trapping. On Error Resume Next ' Defer error trapping. ' Clear the previous button's highlight If Not selectedButton Is Nothing Then selectedButton.BackColor = btnControlDefaultColor lblControl.Caption = "" strLblControlCaption = "" End If ' Set the new button as selected and highlight it Set selectedButton = clickedButton ' Update the label caption If Not DisableLabelChange Then strLblControlCaption = clickedButton.Caption End If ' Apply the button color and control Label flashing ButtonColor frm, clickedButton, True ' Check if lblControl is provided and is a valid object If Not lblControl Is Nothing Then AllowFlashing = Not DisableLabelChange ' Determine whether to trigger flashing lblControl.Caption = strLblControlCaption FlashLabelControl frm, lblControl, False End If Err.Clear ' Clear Err Exit Sub ' Exit to avoid handler. ErrorHandler: ' Error-handling routine. Select Case Err.Number ' Evaluate error number. Case Is = 5 Exit Sub ' Exit to avoid handler. Case Else ' Handle other situations here... MsgBox Err.Number & ": " & Err.Description Resume ' Resume execution at the same line End Select End Sub 2- الاكواد للاستخدام من خلال النموذج ولا اسهل من كده.. يا عينى ع الدلع Private Sub Form_Load() formIsClosing = False End Sub Private Sub Form_Close() formIsClosing = True End Sub Private Sub Command1_Click() ' Call the ChangeCommandButtonColor subroutine with the current form and label control (lblDisplayTitle). ChangeCommandButtonColor Me, Me.lblDisplayTitle End Sub Private Sub Command2_Click() ' Call the ChangeCommandButtonColor subroutine with the current form and label control (lblDisplayTitle). ChangeCommandButtonColor Me, Me.lblDisplayTitle End Sub Private Sub Command3_Click() ' Call the ChangeCommandButtonColor subroutine with the current form and label control (lblDisplayTitle). ChangeCommandButtonColor Me, Me.lblDisplayTitle End Sub Private Sub Command4_Click() ' Call the ChangeCommandButtonColor subroutine with the current form and label control (lblDisplayTitle). ChangeCommandButtonColor Me, Me.lblDisplayTitle End Sub Private Sub Command5_Click() ' Call the ChangeCommandButtonColor subroutine with the current form only without label control (lblDisplayTitle). ' To disable Allow Label Caption Change = True ChangeCommandButtonColor Me, Me.lblDisplayTitle, True End Sub معلش انا شرحت كل شئ ع الأكواد بالانجليزى طبعا مش فلسفة علشان عارف انت هتقول ايه سامعك... علشان العربى بيعمل مشاكل فى الاعدادت الاقليمية للغة لو مكانت مضبوطه بس خلاص • وأخيرا المرفق FlashLabel.accdb

الزمر أين انت من هذه الإجابة الممتازة؟!!! لم أرى اى ضغط على الإعجاب من طرفك , وهل جزاء الإحسان الا الإحسان ؟!!!!على الرغم انك لم تقم برفع ملف وهذا مخالف لتعليمات وقوانين رفع المشاركات بالمنتدى أين الضغط على الإعــــجـــــاب , وكما اتفقنا ان هذا أقل ما يقدم لمن له الفضل عليك بعد ربنا فى حل مشكلتك وتفريج كربتك ؟!!! 💙

جرب هذا الكود Sub get_data() Dim rg As Range Dim ro Sheets("AddShe").Range("A1").CurrentRegion.ClearContents Set rg = Sheets("DatabaseShe").Range("a1").CurrentRegion Sheets("AddShe").Range("A1"). _ Resize(rg.Rows.Count, rg.Columns.Count).Value = _ rg.Value Sheets("AddShe").Range("A1"). _ CurrentRegion.Sort key1:=Range("B2"), Header:=1 ro = Sheets("AddShe").Range("a1").CurrentRegion.Rows.Count Sheets("AddShe").Range("A2").Resize(ro - 1) = _ Evaluate("row(1:" & ro - 1 & ")") End Sub الملف مرفق Saleh.xlsm

اعتقد تريد التخلص من الخلايا الفارغة بين الارقام على حسب ما فهمت تفضل هذه المعادلة =IFERROR(INDEX($L$1:$L$32;AGGREGATE(15;6;(ROW($L$1:$L$32)-ROW($L$1)+1)/($L$1:$L$32<>"");ROWS(I$2:I2)));"") filter (1).xlsx

وعليكم السلام -يمكنك استخدام معادلة المصفوفة(Ctrl+Shift+Enter) فى الخلية J4 =INDEX($B$5:$B$9,MATCH(1,MMULT(--($C$5:$F$9=$K$4),TRANSPOSE(COLUMN($C$5:$F$9)^0)),0)) code departement1.xlsx