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

أخي @صباح2024 إدا كنت قد إستوعبت طلبك سنقوم بتعديل الكود بطريقة مختلفة لنتمكن من تنفيد المطلوب بشكل دقيق لان دمج الاكواد على Private Sub Worksheet_Change(ByVal Target As Range) والإشتغال عليها مباشرة من شأنه أن يسبب لك عدة مشاكل خاصة انك ترغب بتحديث البيانات عند كل تغيير على اي خلية لنفترض أنك قمت باسـتدعاء اي اسم مثلا من الطبيعي ان البيانات السابقة مختلفة بمجرد استدعائها سيتم نسخها للاعمدة الخاصة بالاسم الدي تم اختياره مما سيسبب لك تلف وتعارض في البيانات اسف على الإطالة لاكن لابد من توضيح الفكرة ( اليك ما تم الإشتغال عليه) 1) جلب البيانات من ورقة السجل الى ورقة استدعاء بشرط الإسم 2) تحديث البيانات عند التغيير في أي خلية من الخلايا التي تم تمييزها باللون الأصفر على ورقة استدعاء على الأعمدة المناسبة في ورقة السجل مع مراعات الإسم 3) تم اظافة كود لإنشاء قائمة منسدلة ديناميكية بالأسماء الفريدة من العمود B ( ورقة السجل) بداية من الصف 2 تلقائيا في خلية الإسم (B6) ورقة استدعاء الأكواد المستخدمة : Public Property Get WS() As Worksheet Set WS = Sheets("استدعاء") End Property Public Property Get dest() As Worksheet Set dest = Sheets("السجل") End Property ' خلية الإسم Public Function Clé() As String Clé = WS.Range("B6").Value End Function 'نطاق البحث Public Function rng() As Range Set rng = dest.Range("B2:B" & dest.Cells(dest.Rows.Count, 2).End(xlUp).Row) End Function '======================== ' جلب البيانات من ورقة السجل إلى ورقة "استدعاء" Sub Fetch_data() Dim data As Variant, i As Long, tmp As Range Application.ScreenUpdating = False On Error GoTo CleanExit Set tmp = rng.Find(Clé, LookIn:=xlValues, LookAt:=xlWhole) If tmp Is Nothing Then MsgBox "لم يتم العثور على الإسم" & " : " & Clé & " في السجل", vbExclamation Exit Sub End If For i = 0 To 3 data = dest.Range(tmp.Offset(0, 1 + (i * 9)), tmp.Offset(0, 9 + (i * 9))).Value WS.Range("A" & (9 + (i * 3)) & ":I" & (9 + (i * 3))).Value = data Next i CleanExit: Application.ScreenUpdating = True End Sub '======================== ' تحديث البيانات من ورقة استدعاء الى ورقة السجل Sub Update_data() Dim tmp As Range, cnt() As Variant, OnRng As Range Dim ColArr() As Long, j As Long, i As Long Set OnRng = rng.Find(Clé, LookIn:=xlValues, LookAt:=xlWhole) If OnRng Is Nothing Then MsgBox "لم يتم العثور على الإسم" & " : " & Clé & " في السجل", vbExclamation Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim Irow As Long Irow = OnRng.Row ReDim ColArr(0 To 35) For j = 0 To 35 ColArr(j) = j + 3 Next j ReDim cnt(UBound(ColArr)) For i = 0 To UBound(cnt) cnt(i) = WS.Cells(9 + (i \ 9) * 3, 1 + (i Mod 9)).Value Next i For i = 0 To UBound(ColArr) If dest.Cells(Irow, ColArr(i)).Value <> cnt(i) Then dest.Cells(Irow, ColArr(i)).Value = cnt(i) End If Next i Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub '======================== ' إضافة قائمة منسدلة بالأسماء المتوفرة في ورقة "السجل" Sub Add_listeDéroulante() Dim lr As Long, arr() As String, r As Range, i As Long Dim cnt As New Collection, Names As Range lr = dest.Cells(dest.Rows.Count, 2).End(xlUp).Row On Error Resume Next For Each r In rng If r.Value <> "" Then cnt.Add r.Value, CStr(r.Value) End If Next r On Error GoTo 0 If cnt.Count = 0 Then Exit Sub ReDim arr(1 To cnt.Count) For i = 1 To cnt.Count arr(i) = cnt(i) Next i Set Names = WS.Range("B6") With Names.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:=Join(arr, ",") .IgnoreBlank = True: .InCellDropdown = True: .ShowInput = True: .ShowError = True End With End Sub وفي حدث ورقة استدعاء Private Sub Worksheet_Activate() Add_listeDéroulante End Sub Private Sub Worksheet_Change(ByVal Target As Range) Dim Clé As Range, cntArr As Range Set Clé = WS.Range("B6") If Clé.Value = "" Then Exit Sub If Target.Address = Clé.Address Then On Error GoTo ErrorHandler Fetch_data Exit Sub End If ' عناوين الخلايا المستهدفة Set cntArr = Me.Range("A9:I9, A12:I12, A15:I15, A18:I18") If Not Intersect(Target, cntArr) Is Nothing Then On Error GoTo ErrorHandler Update_data Exit Sub End If Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description On Error GoTo 0 End Sub وأي إستفسار سنكون دائما سعداء بمساعدتك تحويل التغييرات من شيت الاستدعاء الى شيت السجل.xlsm

السلام عليكم في احد مشاريعي ، جابوا لي قائمة اكسل فيها تواريخ مكتوبة بكل ما لذ وطاب من الطرق ، مثل: 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

بعد اذن استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @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

يمكنك تنفيد نفس الأمر بواسطة الأكواد Private Sub Worksheet_Change(ByVal Target As Range) Dim Rng As Variant, a() As Variant, Irow As Long Dim i As Long, lastRow As Long, j As Long Dim WS As Worksheet: Set WS = Sheets("Sheet1") Dim dest As Worksheet: Set dest = Sheets("Sheet2") If Not Intersect(Target, Me.Range("A8:A1000", "C8:D1000")) Is Nothing Then Application.EnableEvents = False Irow = dest.Cells(dest.Rows.Count, "B").End(xlUp).Row If Irow >= 2 Then dest.Range("B2:B" & Irow).ClearContents End If lastRow = WS.Cells(WS.Rows.Count, "C").End(xlUp).Row If lastRow < 8 Then Exit Sub Rng = WS.Range("A8:D" & lastRow).Value ReDim a(1 To UBound(Rng), 1 To 1) j = 1 For i = 1 To UBound(Rng, 1) If Rng(i, 3) = "1/1" And Rng(i, 4) = "ذكر" Then a(j, 1) = Rng(i, 1) j = j + 1 End If Next i If j > 1 Then dest.Range("B2").Resize(j - 1, 1).Value = a End If End If Application.EnableEvents = True End Sub vba المعادلة.xlsb

ومشاركة مع الأستاذ محمد لطفي ، قمت بإنشاء دالة واحدة يتم استدعائها في اي من الزرين لتنفيذ المهمة حسب الزر . Private Sub أمر17_Click() ExportReport "PDF", Me.Namea.Value End Sub Private Sub أمر18_Click() ExportReport "RTF", Me.Namea.Value End Sub Private Sub ExportReport(formatType As String, userName As String) On Error Resume Next Dim fileName As String fileName = userName & " - " & Format(Now(), "yyyy-mm-dd") & " " & Format(Now(), "hh nn AM/PM") & IIf(formatType = "PDF", ".pdf", ".doc") Dim filePath As String filePath = CurrentProject.Path & "\" & fileName DoCmd.OutputTo acOutputReport, namerpts, IIf(formatType = "PDF", acFormatPDF, acFormatRTF), filePath, True, , , acExportQualityPrint End Sub ملفك بعد التعديل ( شريط طباعة.accdb )

تفضل pdf Dim fileName As String fileName = Me.Namea & " - " & Format(Now(), "yyyy-mm-dd") & " " & Format(Now(), "hh mm AM/PM") & ".pdf" DoCmd.OutputTo acOutputReport, namerpts, acFormatPDF, fileName, True, , , acExportQualityPrint Word Dim fileName As String fileName = Me.Namea & " - " & Format(Now(), "yyyy-mm-dd") & " " & Format(Now(), "hh mm AM/PM") & ".doc" DoCmd.OutputTo acOutputReport, namerpts, acFormatRTF, fileName, True, , , acExportQualityPrint شريط طباعة.rar

تفضل أخي الكريم ملف به التاريخ الأحدث و الأقدم باستخدام المعادلات و الأكواد. اختر ما يحلو لك. الأحدث و الأقدم.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل أخي تم تنفيد طلبك بنفس الفكرة إستخراج الأرقام المكررة مع ترحيل التقرير لورقة2 يتضمن إسم الصنف - القيمة المكررة - عدد التكرارات Const Item As Long = 2 ' تحديد أدنى عدد للتكرارات المطلوبة Sub Find_DuplicatedNumbers() Dim WS As Worksheet, dest As Worksheet Dim CodeArr() As Variant, f() As Variant, code As Variant Dim tmp As Object, ligne As Long, a As Long Dim lastRow As Long, i As Long, key As Variant Dim dict As Object, n As Boolean Dim Rng As Range, c As Range, LR As Long Set WS = Sheets("Sheet1") Set dest = Sheets("Sheet2") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row On Error Resume Next CodeArr = WS.Range("A3:A" & lastRow).Value f = WS.Range("B3:B" & lastRow).Value Set tmp = CreateObject("Scripting.Dictionary") For i = 1 To UBound(CodeArr, 1) If Not tmp.Exists(CodeArr(i, 1)) Then tmp.Add CodeArr(i, 1), CreateObject("Scripting.Dictionary") End If On Error GoTo 0 If tmp(CodeArr(i, 1)).Exists(f(i, 1)) Then tmp(CodeArr(i, 1))(f(i, 1)) = tmp(CodeArr(i, 1))(f(i, 1)) + 1 Else tmp(CodeArr(i, 1))(f(i, 1)) = 1 End If Next i n = False For Each code In tmp.Keys Set dict = tmp(code) For Each key In dict.Keys If dict(key) >= Item Then n = True Exit For End If Next key If n Then Exit For Next code If Not n Then MsgBox "لا توجد أي تكرارات للقيم", vbInformation: Exit Sub Application.ScreenUpdating = False LR = WS.Cells(WS.Rows.Count, "F").End(xlUp).Row WS.Range("F3:G" & LR).Borders.LineStyle = xlNone dest.Range("A2:C" & dest.Rows.Count).ClearContents WS.Range("F3:G" & WS.Rows.Count).ClearContents dest.Cells(2, 1).Resize(1, 3).Value = Array("كود الصنف", "القيمة المكررة", "عدد مرات التكرار") ligne = 3 a = 3 For Each code In tmp.Keys Set dict = tmp(code) For Each key In dict.Keys If dict(key) >= Item Then WS.Cells(ligne, 6).Value = code WS.Cells(ligne, 7).Value = key ligne = ligne + 1 dest.Cells(a, 1).Resize(1, 3).Value = Array(code, key, dict(key)) a = a + 1 End If Next key Next code LR = WS.Cells(WS.Rows.Count, "F").End(xlUp).Row Set Rng = WS.Range("F3:G" & LR) For Each c In Rng.Rows If Application.WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous End If Next c Application.ScreenUpdating = True MsgBox dest.Name & " تم ترحيل ملخص الأرقام المكررة إلى", vbInformation End Sub الأرقام المكررة.xlsb

تفضل أخي Sub Find_MissingNumbers3() Dim WS As Worksheet, dest As Worksheet Dim CodeArr() As Variant, NumArr() As Variant, code As Variant Dim tmp As Object, ling As Long, cnt As Boolean, n As Boolean Dim lastRow As Long, i As Long, j As Long, maxNum As Long Dim msg As String, KyCount As Long Set WS = Sheets("Sheet1") Set dest = Sheets("Sheet2") lastRow = WS.Cells(WS.Rows.Count, 1).End(xlUp).Row maxNum = 100 ' تحديد الحد الاقصى للقيم المفقودة n = False For i = 3 To lastRow If Not IsEmpty(WS.Cells(i, 1).Value) And Not IsEmpty(WS.Cells(i, 2).Value) Then n = True Exit For End If Next i If Not n Then MsgBox "الرجاء التحقق من البيانات والمحاولة مرة أخرى", vbExclamation Exit Sub End If Application.ScreenUpdating = False dest.Range("a2:b" & dest.Rows.Count).ClearContents WS.Range("F3:G" & WS.Rows.Count).ClearContents CodeArr = WS.Range("A3:A" & lastRow).Value NumArr = WS.Range("B3:B" & lastRow).Value Set tmp = CreateObject("Scripting.Dictionary") For i = 1 To UBound(CodeArr, 1) If Not tmp.Exists(CodeArr(i, 1)) Then tmp.Add CodeArr(i, 1), New Collection End If tmp(CodeArr(i, 1)).Add NumArr(i, 1) Next i dest.Cells(2, 1).Value = "كود الصنف" dest.Cells(2, 2).Value = "عدد الأرقام المفقودة" ling = 3 Dim a As Long a = 3 For Each code In tmp.Keys KyCount = 0 For j = 1 To maxNum cnt = False For i = 1 To tmp(code).Count If tmp(code)(i) = j Then cnt = True Exit For End If Next i If Not cnt Then WS.Cells(ling, 6).Value = code WS.Cells(ling, 7).Value = j ling = ling + 1 KyCount = KyCount + 1 End If Next j dest.Cells(a, 1).Value = code dest.Cells(a, 2).Value = KyCount a = a + 1 Next code Application.ScreenUpdating = True MsgBox dest.Name & " تم ترحيل ملخص الأرقام المفقودة إلى", vbInformation End Sub الأرقام الناقصة v2.xlsb

المعادلة =IF(B2="";"";IF(B2<=C2;2%;"1%")) الملف تحقق التارحت.xlsx