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

ده بسبب انه حقل متعدد القيم ولا يمكن استخدام like مباشرتا ولهذا يجب اضافة Value الى اسم الحقل [grade] انظر للسطر التالي StrWhere = StrWhere & " and [grade].Value like '*" & Me.tx1 & "*'"

أخي الكريم ، أولاً أهلا وسهلا بك معنا في عالمنا الصغير المتواضع .. ثانياً وبما أنك جديد معنا فمن حقك لفت انتباهك لما يلي :- ضرورة إرفاق ملف مع الطلب ، ولا تنتظر أحد يطلبه منك . ( اقرأ قواعد المشاركة في المنتدى ) التفسير والإيضاح للمطلوب بشكل وافي وكافي وشافي ( ولا تبخل على نفسك بالشرح ) حاول الابتعاد عن الأسماء التي تكون باللغة العربية ( للحقول والجداول والنماذج ومكوناتها والإستعلامات ..... إلخ ) ، أو حتى أرقام ورموز أو مسميات محجوزة مثل ( Name , Date , .... إلخ ) هناك الكثير من الإخواة والأساتذة المتواجدين هنا ؛ ولكن هذا لا يعني أن الجميع قد يكون متفرغاً بأي وقت . استخدم كلمات مثل ( للرفع ، للمتابعة ، Up ... إلخ ) كي يبقى الموضوع متابعاً ،لا ان تغيب عنه اسبوعين وتعود له لتلقى الإجابة التي تريدها جاهزة . خذ كلامي بسعة صدر ورحابة ( وثق تماماً أن ما ذكرته لك هو لمصلحتك حتى تتخطى الكثير من العقبات والمشاكل لاحقاً أثناء تصميمك لبرامجك ومشاريعك )

بعد اذن استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @jjafferr فعلا الموضوع مهم وملح جدا جدا لمن يقع فى هذه الورطة خاصة مع كثرة عدد السجلات التى تحتوى على صيغ تواريخ مختلفة وبالاخص لو كانت بها مشاكل اثراء للموضوع صادفنى هذه المشكلة ذات مرة فى العمل وهذه هى الوظيفة التى قمت بكتابتها للتعامل مع مختلف الصيغ والتسيقات حسب المشاكل التى واجهتها آن ذاك Function RectifyDateFormat(inputString As String) As Variant ' Enable error handling ' This line sets up an error handling routine. If an error occurs in the code that follows, ' execution will jump to the ErrorHandler label, allowing for controlled error management. On Error GoTo ErrorHandler ' Remove leading and trailing spaces ' This line uses the Trim function to eliminate any spaces at the beginning and end of the input string. ' This is important for ensuring that the date format is clean and free of unnecessary spaces ' which could lead to incorrect parsing of date parts later in the function. inputString = Trim(inputString) ' Replace Indian numerals with standard numerals ' This block replaces Indian numerals (Unicode character codes from 1632 to 1641) with standard Arabic numerals (0-9). ' The loop iterates through the Unicode range for Indian numerals and replaces each occurrence ' in the input string with its equivalent standard numeral by calculating its index. Dim i As Integer For i = 1632 To 1641 inputString = Replace(inputString, ChrW(i), CStr(i - 1632)) Next i ' Replace non-standard symbols with hyphens ' This section defines an array of symbols that are considered non-standard for date formatting. ' The goal is to standardize the date input by replacing these symbols with hyphens, ' making it easier to parse the date parts later on. Dim SymbolsToRemove As Variant SymbolsToRemove = Array("(", ")", "?", "*", " ", "!", "\", "/", "//", ".", "_", "--", "|", ",", Chr(227), Chr(34)) inputString = ReplaceSymbols(inputString, SymbolsToRemove) ' Remove leading and trailing hyphens ' This line first replaces any occurrence of double hyphens (--) with a single hyphen (-). ' After replacing, Trim is used to remove any spaces around the string. ' This ensures that any malformed input resulting in multiple hyphens is corrected before further processing. inputString = CleanHyphens(inputString) ' Split the input string into date parts ' This line splits the cleaned input string into an array of date parts using the hyphen (-) as a delimiter. ' The result is stored in strDateParts, which will contain the individual components of the date (day, month, year). Dim strDateParts() As String strDateParts = Split(inputString, "-") ' Ensure the input contains exactly three parts ' This condition checks if the upper bound of the strDateParts array is not equal to 2. ' In VBA, the array index starts from 0, so an array with exactly three elements will have ' an upper bound of 2 (i.e., elements at index 0, 1, and 2). ' If the input does not contain exactly three parts, the function returns Null ' to indicate an invalid date format, and exits the function to prevent further processing. If UBound(strDateParts) <> 2 Then RectifyDateFormat = Null Exit Function End If ' Assign the split parts to variables, ensuring they are trimmed ' This line assigns the individual parts of the date from the strDateParts array ' to three separate variables (strPartOne, strPartTwo, strPartThree). ' The Trim function is used to remove any leading or trailing whitespace from each part. ' This ensures that any extra spaces do not affect the subsequent processing of date parts. Dim strPartOne As String, strPartTwo As String, strPartThree As String strPartOne = Trim(strDateParts(0)): strPartTwo = Trim(strDateParts(1)): strPartThree = Trim(strDateParts(2)) ' Debug output for each part ' This line outputs the individual parts of the date to the immediate window for debugging purposes. ' Debug.Print "Part One: " & strPartOne & " | Part Two: " & strPartTwo & " | Part Three: " & strPartThree ' Ensure that the parts can be converted to numbers ' This conditional statement checks if each of the date parts (strPartOne, strPartTwo, strPartThree) ' can be converted to a numeric value. It uses the IsNumeric function to evaluate whether ' each part is a valid number. If any of the parts cannot be converted to a number, it indicates ' an invalid date format. In this case, the function returns Null to signify that the input is not a valid date, ' and exits the function to prevent further processing. If Not IsNumeric(strPartOne) Or Not IsNumeric(strPartTwo) Or Not IsNumeric(strPartThree) Then RectifyDateFormat = Null Exit Function End If ' Declare integer variables for the day, month, and year ' These declarations create integer variables to hold the day, month, and year components of the date. ' These will be used for further processing and validation of the date before returning the formatted result. Dim intDay As Integer, intMonth As Integer, intYear As Integer ' Analyze the parts to determine their roles ' This block of code evaluates the lengths of the date parts to determine their roles as day, month, or year. ' Depending on the format of the input string, it assigns the appropriate values to intYear, intMonth, and intDay. AnalyzeDateParts strPartOne, strPartTwo, strPartThree, intDay, intMonth, intYear ' Validate the final values ' This conditional checks if the final values for day, month, and year are valid. ' If any value is outside the expected range, the function returns Null to indicate an invalid date. If Not IsValidDate(intDay, intMonth, intYear) Then RectifyDateFormat = Null Exit Function End If ' Create the date and format it ' This line creates a date using the DateSerial function, which takes year, month, and day as parameters. ' The resulting date is then formatted as a string in the "dd/mm/yyyy" format. ' The formatted date string is assigned to the function's return value, RectifyDateFormat. RectifyDateFormat = Format(DateSerial(intYear, intMonth, intDay), "dd/mm/yyyy") Exit Function ' This line exits the function normally. ' If no errors occur, the code will not reach the ErrorHandler section. ErrorHandler: ' Handle errors gracefully ' If an error occurs in the preceding code, this line sets the return value of the function to Null, ' indicating that the date format correction failed due to an error. RectifyDateFormat = Null End Function Private Function ReplaceSymbols(inputString As String, SymbolsToRemove As Variant) As String ' This function iterates through an array of symbols that should be replaced with hyphens. ' Each symbol in the SymbolsToRemove array is checked, and if it's not a hyphen, ' it is replaced in the input string with a hyphen. Dim strSymbol As Variant For Each strSymbol In SymbolsToRemove If strSymbol <> "-" Then inputString = Replace(inputString, strSymbol, "-") End If Next strSymbol ReplaceSymbols = inputString End Function Private Function CleanHyphens(inputString As String) As String ' This function replaces double hyphens with a single hyphen and trims the input string. inputString = Trim(Replace(inputString, "--", "-")) ' Remove leading hyphens ' This loop checks if the first character of the input string is a hyphen. ' If it is, the hyphen is removed by taking the substring starting from the second character. Do While Left(inputString, 1) = "-" inputString = Mid(inputString, 2) Loop ' Remove trailing hyphens ' This loop checks if the last character of the input string is a hyphen. ' If it is, the hyphen is removed by taking the substring up to the second-to-last character. Do While Right(inputString, 1) = "-" inputString = Left(inputString, Len(inputString) - 1) Loop CleanHyphens = inputString End Function Private Sub AnalyzeDateParts(strPartOne As String, strPartTwo As String, strPartThree As String, _ ByRef intDay As Integer, ByRef intMonth As Integer, ByRef intYear As Integer) ' This subroutine analyzes the lengths of the date parts to determine their roles as day, month, or year. ' Depending on the format of the input string, it assigns the appropriate values to intYear, intMonth, and intDay. If Len(strPartOne) = 4 Then ' Year is first (Format: YYYY-MM-DD) intYear = CInt(strPartOne) intMonth = CInt(strPartTwo) intDay = CInt(strPartThree) ElseIf Len(strPartThree) = 4 Then ' Year is last (Format: DD-MM-YYYY) intYear = CInt(strPartThree) intMonth = CInt(strPartTwo) intDay = CInt(strPartOne) ElseIf Len(strPartTwo) = 4 Then ' Year is in the middle (Format: DD-YYYY-MM or MM-YYYY-DD) intYear = CInt(strPartTwo) If CInt(strPartOne) > 12 Then intDay = CInt(strPartOne) intMonth = CInt(strPartThree) ElseIf CInt(strPartThree) > 12 Then intDay = CInt(strPartThree) intMonth = CInt(strPartOne) Else intDay = CInt(strPartOne) intMonth = CInt(strPartThree) End If Else ' All parts are small numbers (Format: D-M-YY) intDay = CInt(strPartOne) intMonth = CInt(strPartTwo) intYear = CInt(strPartThree) ' Confirm year is in the correct range ' If the year is provided as a two-digit number, it will be treated as a year in the 2000s. If intYear < 100 Then intYear = intYear + 2000 End If End If End Sub Private Function IsValidDate(intDay As Integer, intMonth As Integer, intYear As Integer) As Boolean ' This function checks if the provided day, month, and year are valid. ' It verifies that the month is between 1 and 12 and that the day is appropriate ' for the given month and year (not exceeding 31 for any month). IsValidDate = (intMonth >= 1 And intMonth <= 12) And _ (intDay >= 1 And intDay <= 31) And _ (intYear >= 1900 And intYear <= 2100) End Function وللتجربة لكل الحالات تقريبا من داخل المحرر '************************************************************************************************************************************* ' Sub: TestRectifyDateFormat ' Purpose: This subroutine tests the RectifyDateFormat function with various input date strings ' to ensure that the function handles different formats and returns the expected results. ' ' Usage: Call TestRectifyDateFormat to run the tests and print the results to the debug output. ' '********************************************************************** ' Author: officena.net™ , Mohammed Essam © , soul-angel@msn.com ® ' Date: October 2024 '********************************************************************** Sub TestRectifyDateFormat() Dim testDate As String Dim result As Variant ' Test various date formats testDate = "30/11/2009" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "2012-06-25" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "21/6/2015م" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = """ 9/1/2014""" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "30\11\2009" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "5/1999/26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "25/1999/6" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "5/1994/ 26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "5 1995 26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result Debug.Print "-----------------------------------------------" testDate = "6 1996 26" result = RectifyDateFormat(testDate) Debug.Print "Input: " & testDate & " | Result: " & result End Sub RectifyDate.accdb

السلام عليكم في احد مشاريعي ، جابوا لي قائمة اكسل فيها تواريخ مكتوبة بكل ما لذ وطاب من الطرق ، مثل: 30/11/2009 ، 2012-06-25 ، 21/6/2015م ، " 9/1/2014" ، 30\11\2009 ، 5/1999/26 ، 25/1999/6 ، 5/1994/ 26 ، وحتى بعضها بالارقام الهندية ، فعملت الدالة التالية ، والتي ترسل لها التاريخ المطلوب تعديله ، والدالة تصلح التاريخ وترجعه. وستلاحظون اني استخدمت الدالة DateSerial ، حتى اعطي اليوم والشهر والسنة بياناتهم يدويا ، بدلا عن استعمال CDate . هذه هي الدالة: Function Date_Rectified(D As String) As Date On Error Resume Next Dim x() As String Dim P1 As String, P2 As String, P3 As String D = Trim(D) D = Replace(D, "(", "") D = Replace(D, ")", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, " ", "") D = Replace(D, "*", "") D = Replace(D, "م", "") D = Replace(D, ChrW(1632), "0") 'الرقم الهندي صفر D = Replace(D, ChrW(1633), "1") D = Replace(D, ChrW(1634), "2") D = Replace(D, ChrW(1635), "3") D = Replace(D, ChrW(1636), "4") D = Replace(D, ChrW(1637), "5") D = Replace(D, ChrW(1638), "6") D = Replace(D, ChrW(1639), "7") D = Replace(D, ChrW(1640), "8") D = Replace(D, ChrW(1641), "9") D = Replace(D, "!", "-") D = Replace(D, "/", "-") D = Replace(D, "//", "-") D = Replace(D, "\", "-") D = Replace(D, ".", "-") D = Replace(D, "_", "-") D = Replace(D, "|", "-") D = Replace(D, ",", "-") D = Replace(D, Chr(34), "") If Len(D) = 4 Then 'starts with year, but its 4 digits only:1999 'convert to 1-1-1999 OR EMPTY Date_Rectified = DateSerial(D, 1, 1) Exit Function End If If D = "5/1994/ 26" Then Debug.Print D End If x = Split(D, "-") P1 = x(0): P2 = x(1): P3 = x(2) If Len(P1) = 4 And Len(P2) <> 0 Then 'starts with year, and month exist: 1999-1-2 Date_Rectified = DateSerial(P1, P2, P3) ElseIf Len(P3) = 4 And Len(P2) <> 0 Then 'ends with year, and month exist: 2-1-1999 Date_Rectified = DateSerial(P3, P2, P1) ElseIf Len(P2) = 4 And Len(P1) <= 12 Then 'year in the middle, day and month exist: 5/1999/26 Date_Rectified = DateSerial(P2, P1, P3) ElseIf Len(P2) = 4 And Len(P1) > 12 Then 'year in the middle, day and month exist: 25/1999/6 Date_Rectified = DateSerial(P2, P3, P1) Else 'otherwise Date_Rectified = Null End If End Function

ههههههه انا جاوبت فى سرى ينفع لا بلاش هزار لحسن حد يزعق لى انا بالفعل حضرتت الاجابة وفى آخر لحظة تراجعت عن عمل المشاركة ورفع المرفق السبب: بكل صراحة لم أكن راضيا عنها جارى العمل على تعديل اكواد لتكون الإجابة شاملة و كافية و وافيه بقدر الإمكان للإقتراب قدر الإمكان من أقرب درجات الكمال لأكون راض عن المشاركة

مشاركة مع أخي الكريم @ازهر عبد العزيز .. Private Sub dev_AfterUpdate() If Me.dev < 5000000000 Then Me.Undo End If End Sub

لسه فيه مفاجآت ما خطرتش على بالك 😅🖐

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) هذه المرة دعوة لتجربة لعبة المتاهة Maze لأول مرة من خلال آكسيس ميزات اللعبة :- التحكم الكامل من خلال الأسهم في لوحة المفاتيح . تجميع النقاط كلما التهمت الشخصية عدداً أكبر من ( ) . تخسر إذا لامست هذا الكائن في اللعبة ( ) عند طلب المساعدة باستخدام ( ) فإنه سيتم خصم 10 نقاط من رصيد النقاط التي قمت بتجميعها . اللعبة في إصدارها الأول حالياً وسيكون قريباً الكثير من المستويات في اللعب ، وهذه فقط دعوة لتجربتها وإفادتي بآرائكم حول تطويرها وتحديثها وأترككم مع ملف التحميل : Maze Game.zip

ال فهمته انك عاوز تعمل برنامج يقوم بتسجيل المرضي وعدم السماح للموظف المسؤل عن تسجيل حضور الكشف بالتلاعب هل هذا صحيح ؟ هذا امر بسيط ممكن بالنماذج والاكواد وتنتهي المسأله اذا فكل المطلوب اولا اعادة ظبط البرنامج وسنقوم بمساعدة بعض ان شاء الله علشان تمشي على طريق صحيح هل انت مستعد ؟

جرب المرفق time.accdb عذرا لم اشاهد ردك

وعليكم السلام ورحمة الله وبركاته ،، استخدم الكود التالي لتقسيم التاريخ الحالي وتوزيعه الى مربعات النص :- Private Sub oktxt_Click() Me.yn.Value = Year(Date) Me.mn.Value = Month(Date) Me.dn.Value = Day(Date) Me.mt.Value = Format(Date, "mmmm") Me.dt.Value = Format(Date, "dddd") End Sub ملفك بعد التعديل : time.accdb

جرب Private Sub Form_BeforeClose(Cancel As Integer) Dim userResponse As Integer ' تحقق من الشرط If Me.t54 = 6 Then If Not (Me.dev Like "5000000000") Then ' عرض رسالة تأكيد userResponse = MsgBox("هل تريد إعادة الحقل dev إلى القيمة السابقة؟", vbYesNo + vbQuestion, "تأكيد") If userResponse = vbYes Then ' قم بإعادة الحقل إلى القيمة السابقة Me.dev = "" ' أو قم بتغيير هذا إلى القيمة التي تريد إعادة تعيينها ' يمكنك أيضاً إضافة كود هنا لتخزين القيمة السابقة قبل تغييرها End If End If End If End Sub او Private Sub Form_BeforeUpdate(Cancel As Integer) Dim t54Value As Integer Dim devValue As String Dim response As Integer t54Value = Me.t54 devValue = Me.dev ' تحقق إذا كانت قيمة t54 تساوي 6 وأيضاً إذا dev لا يحتوي على الرقم 5 If t54Value = 6 And Not devValue Like "*5" Then ' إظهار رسالة تأكيد response = MsgBox("الحقل dev يجب أن يحتوي على الرقم 5. هل ترغب في الاستمرار؟", vbYesNo + vbExclamation, "تأكيد") If response = vbNo Then ' إذا اختار المستخدم "لا"، أعد الحقل t54 إلى Null أو القيمة الافتراضية Me.t54 = Null ' أو يمكنك تعيين قيمة معينة بدلًا من Null Cancel = True ' يمنع إغلاق النموذج End If End If End Sub

محاولة متواضعة في المرفق بعد التعديل ، تم الغاء التخطيط Layout للعناصر ( Name , id1 ) وابقائها فقط على ( Date1,Date2 ) ، وإضافة سطر يجعل عرض العمود = 0 عند الإخفاء . 1.accdb

العفو يحثنا ديننا الحنيف على طلب العلم حتى الممات دائما نتعلم ونطلب العلم وان شاء الله وان طال الطريق يسهله الله تعالى علينا بفضله ثم بفضل وكرم اساتذتنا العظماء الذين نتعلم منهم طرق الافكار والحلول جزاكم الله خيرا على دعواتكم الطيبة واسال الله تعالى ان يرزقكم بركتها وفضلها وكل المسلمون ان شاء الله

هلا والله.. والله اشتقنا يا اهلا بمفاجئاتك انت لازم تطلع عنيننا يا استاذنا الغالى انا قلت كتبت الكود على حسب المشكلات اللى واجهتنى وفتها بس ولا يهمك انت تأمر من عيونى بس استبدل الدالة التالية Private Sub AnalyzeDateParts(strPartOne As String, strPartTwo As String, strPartThree As String, _ ByRef intDay As Integer, ByRef intMonth As Integer, ByRef intYear As Integer) ' This subroutine analyzes the lengths of the date parts to determine their roles as day, month, or year. ' Depending on the format of the input string, it assigns the appropriate values to intYear, intMonth, and intDay. If Len(strPartOne) = 4 Then ' Year is first (Format: YYYY-MM-DD or YYYY-DD-MM) intYear = CInt(strPartOne) If CInt(strPartTwo) > 12 Then ' Format: YYYY-DD-MM intDay = CInt(strPartTwo) intMonth = CInt(strPartThree) Else ' Format: YYYY-MM-DD intMonth = CInt(strPartTwo) intDay = CInt(strPartThree) End If ElseIf Len(strPartThree) = 4 Then ' Year is last (Format: DD-MM-YYYY) intYear = CInt(strPartThree) intMonth = CInt(strPartTwo) intDay = CInt(strPartOne) ElseIf Len(strPartTwo) = 4 Then ' Year is in the middle (Format: DD-YYYY-MM or MM-YYYY-DD) intYear = CInt(strPartTwo) If CInt(strPartOne) > 12 Then intDay = CInt(strPartOne) intMonth = CInt(strPartThree) ElseIf CInt(strPartThree) > 12 Then intDay = CInt(strPartThree) intMonth = CInt(strPartOne) Else intDay = CInt(strPartOne) intMonth = CInt(strPartThree) End If Else ' All parts are small numbers (Format: D-M-YY) intDay = CInt(strPartOne) intMonth = CInt(strPartTwo) intYear = CInt(strPartThree) ' Confirm year is in the correct range ' If the year is provided as a two-digit number, it will be treated as a year in the 2000s. If intYear < 100 Then intYear = intYear + 2000 End If End If End Sub واستبدل السطر الخاص بالمصفوفة المصفوفة القديمة بالمصفوفة الاتية SymbolsToRemove = Array("(", ")", "?", "*", " ", "!", "-", "#", "@", "+", "\", "/", "//", ".", "_", "--", "|", ",", Chr(227), Chr(34)) المرفق بعد التعديلات RectifyDate (V 2).accdb

وعليكم السلام اقتباس و توضيح فقط لا اكثر 1. افتح نموذجك في وضع التصميم. 2. انقر بزر الماوس الأيمن على الحقل "dev" واختر "خصائص". 3. اذهب إلى علامة التبويب "الحدث" وابحث عن "After Update". 4. انقر على زر "..." الموجود بجوار "After Update" لفتح محرر VBA. 5. أدخل الكود التالي: ```vba Private Sub dev_AfterUpdate() If Me.dev < 5000000000 Then MsgBox "القيمة المدخلة يجب أن تكون 5000000000 أو أكبر. سيتم التراجع عن التحديث." ' قم بإعادة الحقل إلى حالته السابقة Me.Undo End If End Sub ### شرح الكود: - `Private Sub dev_AfterUpdate()`: هذا هو حدث "After Update" الخاص بحقل "dev". - `If Me.dev < 5000000000 Then`: يتحقق مما إذا كانت القيمة المدخلة أقل من 5000000000. - `MsgBox`: يعرض رسالة تنبه المستخدم بأن القيمة المدخلة غير صحيحة. - `Me.Undo`: يقوم بالتراجع عن التحديث وإعادة القيمة السابقة للحقل. بهذا الشكل، إذا أدخل المستخدم قيمة أقل من 5000000000، سيظهر تحذير وسيتراجع عن التحديث.

وعليكم السلام If Me.dev <> 5000000000 Then dev = OldValue End If

ما شاء الله لما بشوف اسلوبكم فى كتابة الاكواد وافكاركم بحث اني جاهل 🤪 ولم اتعلم شئ وان الطريق لسه طوووووووووووويل علشان اقرب منكم الله يجازيكم عنا كل خير ويشفي مرضاكم ومرضي المسلمين ويبارك لكم فى صحتكم🤲

الاداة مفتوحة المصدر 😎 يمكنك التعديل وتقديم الحلول والاقتراحات تحديث البرنامج كما ذكر 1)- تسريع شريط التقديم مع خيار الغاء النسخ الاحتياطية السبب : عند توفر اجهزة وحدات التخزين فيه تقوم بعمل نسخ احتياطية بسرعة واداء عالي من غير تفشير مقصد لا ترفع مستوى التشفير كما يأمن اجهزة وحدات التخزين تأمين عند عطل احدى الاقراص فقط استبدال القرص المعطوب مثل الاجهزة جهاز سكليوجي و ناس 2)- اضافة مباشر لكل رقم المدني القومي عند اختيار الدولة على سبيل المثال مصر =14 الكويت = 12 السعودية = 10 3)- اضافة قائمة العملاء للمراجعين ودخول والربط عن طريق DlookUp '=================================( IF Null Record Or NO Give Me Only A_Link_A_ID_Card ) Dim strsq2 As String Dim Ttb3 As Recordset strsq2 = "Delete * from A_Link_A_ID_Card" CurrentDb.Execute strsq2 Set Ttb3 = CurrentDb.OpenRecordset("A_Link_A_ID_Card") Ttb3.AddNew Ttb3![ID_Card] = Me.tx Ttb3.Update ======================================== ( بتحديث ) عمل تعديل على بعض الاكواد مع التصحيح والانتهاء ثم للرفع بمكتبة موقع ☕ ========================( فيديوين +2 ) '==================================( Prt 1) ====================================( Prt 2) تحميل النسخة https://www.mediafire.com/file/c8cshc4ayh5cwbz/Update_Link_db_With_User_Customar_Ms_Access.rar/file

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا =IFERROR(IF(A14="","",LOOKUP(2,1/(INDEX($B$2:$E$9,MATCH(A14,$A$2:$A$9,0),0)<>""),INDEX($B$2:$E$9,MATCH(A14,$A$2:$A$9,0),0))),"بدون نتيجة") أو بإستخدام vba Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim Code As Variant, dataA As Variant, dataB As Variant Dim rngA As Range, rngB As Range, rngC As Range Dim tmp As Variant, result As String Dim cell As Range, col As Long Dim msg As String: msg = "بدون نتيجة" Set rngA = Me.Range("A2:A9") Set rngB = Me.Range("B2:E9") Set rngC = Me.Range("A14:A21") Application.ScreenUpdating = False Application.EnableEvents = False On Error GoTo CleanExit If Not Intersect(Target, Union(rngB, rngC)) Is Nothing Then dataA = rngA.Value dataB = rngB.Value For Each cell In rngC If Trim(cell.Value) <> "" Then tmp = Application.Match(cell.Value, rngA, 0) If Not IsError(tmp) Then result = msg For col = 4 To 1 Step -1 If Trim(dataB(tmp, col)) <> "" Then result = dataB(tmp, col) Exit For End If Next col cell.Offset(0, 1).Value = result Else Code = cell.Value cell.Resize(1, 2).ClearContents MsgBox "الكود " & Code & " غير موجود", vbExclamation End If Else cell.Offset(0, 1).ClearContents End If Next cell End If CleanExit: Application.EnableEvents = True Application.ScreenUpdating = True End Sub ppp.xlsb

العفو أخي يسعدنا أننا إستطعنا مساعدتك إليك طريقة أسرع ومختصرة Option Explicit Sub test2() Dim lastrow&, a&, i&, n&, cnt& Dim f As Worksheet, WS As Worksheet, OnRng As Variant Set WS = Sheets("الخزينه") Set f = Sheets("تحصيلات نقدية") lastrow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row a = f.Cells(f.Rows.Count, "A").End(xlUp).Row + 1 OnRng = WS.Range("B4:G" & lastrow).Value For i = 1 To UBound(OnRng, 1) cnt = Application.WorksheetFunction.CountIfs(f.Range("A2:A" & a - 1), OnRng(i, 1), _ f.Range("B2:B" & a - 1), OnRng(i, 6), _ f.Range("C2:C" & a - 1), OnRng(i, 2), _ f.Range("D2:D" & a - 1), OnRng(i, 5)) If cnt = 0 And (OnRng(i, 6) = "دفعه" Or OnRng(i, 6) = "تصفيه") Then f.Cells(a, 1).Resize(1, 4).Value = Array(OnRng(i, 1), OnRng(i, 6), OnRng(i, 2), OnRng(i, 5)) a = a + 1 n = n + 1 End If Next i MsgBox IIf(n > 0, "تم ترحيل البيانات بنجاح", "البيانات محدثة مسبقا") End Sub مشروع خزنه 1.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته بعد إذن صاحب الملف أستادنا الكبير @ضاحي الغريب وتجنبا للتعديل على الأكواد الخاصة به رغم أنني متأكد أنه تم التلاعب بها مسبقا قمت بحدف جميع الأكواد الموجودة داخل اليوزرفورم وإعادة ترتيب تسلسل عناصر TEXTBOX بما يتناسب مع شكل وتصمييم الملف وإنشاء أكواد جديدة بطريقتي الخاصة و إظافة بعض اللمسات مع الاحتفاظ على نفس فكرة إشتغال اليوزرفورم تفضل اخي @ehabaf2 أتمنى أن يلبي طلبك Dim Btn(1 To 5) As New ClasseBoutons Dim ExitLoop As Boolean Const dict As Integer = 61 Private Const b As Long = 1 Private Const SearchColumn As String = "A" Public Property Get WS() As Worksheet: Set WS = Sheets("DATA"): End Property Private Sub UserForm_Initialize() For i = 1 To 5 Set Btn(i).GrBoutons = Me("commandbutton" & i) Next i Dim temp() Col = WS.Evaluate("SUM(0+(A5:A" & _ WS.Cells(WS.Rows.Count, "A").End(xlUp).Row & "<>""""))") Set tbl = CreateObject("Scripting.Dictionary") For Each c In WS.Range("A4:A" & WS.[a65000].End(xlUp).Row) If c.Value <> "" Then tbl.Item(c.Value) = c.Value Next c temp = tbl.items Tri temp, LBound(temp), UBound(temp) Me.ComboBox1.List = temp Me.limite.Value = Col End Sub '**************************** Private Sub ComboBox1_Change() ' بجث وجلب البيانات Dim fnd As Range, i As Long, sequence As String sequence = Me.ComboBox1 If Len(sequence) = 0 Then Exit Sub If IsNumeric(sequence) Then Set fnd = WS.Columns(SearchColumn).Find(sequence, , , xlWhole) If fnd Is Nothing Then MsgBox "! لم يتم العثور على رقم التسلسل " & " : " & _ sequence & " " & "في قاعدة البيانات", 16, "تم ايقاف تنفيد الكود" Me.ComboBox1 = "" Exit Sub End If For i = 1 To dict Me.Controls("TextBox" & i).Value = fnd.Offset(, i - b).Value Next i End If End Sub '************************************ Private Sub CommandButton1_Click() ' ترحيل Dim i As Long, src As Range Set src = WS.Range("A" & WS.Rows.Count).End(xlUp) If Me.TextBox3 = "" Then: MsgBox "يرجى اظافة " & ":" & Me.Label2.Caption, 16: Exit Sub r = MsgBox("ترحيـل البيانات؟", vbYesNo, "تأكيـــد"): If r <> vbYes Then Exit Sub For i = 1 To dict Application.ScreenUpdating = False src.Offset(b, i - b).Value = Me.Controls("TextBox" & i).Value With WS.Range("A5:A" & WS.Cells(WS.Rows.Count, "C").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-4") End With Me.Controls("TextBox" & i).Value = Null: Me.ComboBox1 = Empty Next i UserForm_Initialize Application.ScreenUpdating = True End Sub '******************************** Private Sub CommandButton3_Click() 'حدف Dim sequence As String sequence = Me.ComboBox1 If Len(sequence) = 0 Then Exit Sub r = MsgBox("حدف البيانات؟", vbYesNo, "تأكيـــد"): If r <> vbYes Then Exit Sub Application.ScreenUpdating = False With WS For i = .[a65000].End(xlUp).Row To 5 Step -1 If .Cells(i, (SearchColumn)) = sequence Then .Cells(i, 1).Resize(1, 61).Delete Shift:=xlUp Next i With Range("A5:A" & .Cells(.Rows.Count, "B").End(xlUp).Row) .Value = Evaluate("ROW(" & .Address & ")-4") End With End With Clear_TextBox Application.ScreenUpdating = True UserForm_Initialize End Sub '******************************** Private Sub CommandButton2_Click() ' تعديل Dim fnd As Range, sequence As String Dim i As Integer sequence = Me.ComboBox1 If Len(sequence) = 0 Then Exit Sub r = MsgBox("تعديل البيانات؟", vbYesNo, "تأكيـــد"): If r <> vbYes Then Exit Sub Application.ScreenUpdating = False Set fnd = WS.Columns(SearchColumn).Find(sequence, , , xlWhole) For i = 1 To dict WS.Cells(fnd.Row, i) = Controls("textbox" & i).Value Next i Clear_TextBox Application.ScreenUpdating = True UserForm_Initialize End Sub ملاحظة : أكواد البحث و التعديل والحدف يتم تنفيدها بشرط عمود التسلسل / الترحيل بشرط وجود قيمة في Textbox رقم الموظف واي اظافة او تعديل لا تتردد في دكره سنكون سعداء دائما بحصولك على النتائج المتوقعة لقد تركت لك إمكانية وضع توقيعك على اليوزرفورم 😃😃😃 بالتوفيق............ ملف ترحيل بالفورم V2.xlsm

المثال هو " تم تنفيذ الطلبية رقم 5100152369 بتاريخ 16 اكتوبر 2024 "