عندي كمية ارقام كثيرة احتاج اطلع منها الرقم الناقص

[malshaqrawi]

السلام عليكم ورحمة الله وبركاته

 

عندي مجموعة ارقام متسلسلة احتاج اطلع منها الارقام المفقوده جربت كل الطرق لك يرفض بسبب حجم

 

حتى بطريقة ازالة التكرار يرفض

الفرز النهائي لي اسماء المرضى.rar

[وجيه شرف الدين]

جرب هذه المعادلة

الفرز النهائي لي اسماء المرضى.xlsx

[سليم حاصبيا]

لقد قمت بتحميل ملف كبير جداً يصعب فيه مراقبة سير المعادلات

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

الكود

Option Explicit

Sub find_missing()
 Dim i, k%: k = 1
 Dim Rg As Range: Set Rg = Range("a1").CurrentRegion
 Dim coll_1 As Object
 Dim coll_2 As Object
 Dim arr1, arr2, total_arr()
 Set coll_1 = CreateObject("system.collections.arraylist")
 Set coll_2 = CreateObject("system.collections.arraylist")
 Range("G2:H" & Rows.Count).ClearContents
  With coll_1
   For i = 1 To Rg.Cells.Count
      If Not .contains(Rg.Cells(i).Value) Then
    .Add Rg.Cells(i).Value
       End If
    Next
    .Sort
    arr1 = .toarray
    .Clear
  End With
'==========================
With coll_2
   For i = 1 To Rg.Cells.Count
    If Not .contains(i) Then
    .Add i
    End If
    Next
    .Sort
    arr2 = .toarray
    .Clear
  End With
  Range("G2").Resize(UBound(arr1) - LBound(arr1) + 1) = _
  Application.Transpose(arr1)

'====================

 For i = 0 To Rg.Cells.Count - 1
   If IsError(Application.Match(arr2(i), arr1, 0)) Then
     ReDim Preserve total_arr(1 To k)
     total_arr(k) = arr2(i)
     k = k + 1
    End If
 Next
   Range("H2").Resize(k - 1) = _
  Application.Transpose(total_arr)
  Erase arr1: Erase arr2
  Set coll_1 = Nothing: Set coll_2 = Nothing
 
End Sub

الملف مرفق

 

 

Find_Missing .xlsm

[Ali Mohamed Ali]

أحسنتما بارك الله فيكم وجزاكم الله كل خير

[وجيه شرف الدين]

ما شاء الله استاذ سليم الله يبارك فيكم وفى اعمالكم  ادامكم الله فى طاعته وعلى مساعدت الاخرين

شكرا استاذ على  على هذا التشجيع الدائم

[سليم حاصبيا]

ممكن هذا الماكرة ان يفي بالغرض

Option Explicit

Sub Find_Missing_number()
Dim RG As Range
Dim i#, C#, Col#, M#
Dim My_Max#, My_Min#
Dim T#: T = Sheets("Sheet1").Range("a1").CurrentRegion.Columns.Count
Dim My_count#
M = 1
Dim dic As Object
Sheets("salim").Cells.Clear
Set dic = CreateObject("scripting.dictionary")
 For C = 1 To T
   Set RG = Sheets("Sheet1").Range("a1").CurrentRegion.Columns(C)
   My_Max = Application.Max(RG)
   My_Min = Application.Min(RG)
 With dic
        For i = My_Min To My_Max
          If IsError(Application.Match(i, RG, 0)) Then
              If Not .exists(i) Then
                .Add i, ""
              End If
          End If
        Next
        
        My_count = .Count

    With Sheets("salim").Cells(1, M)
      If My_count <> 0 Then
         .Value = "Missing in col " & C
         .Interior.ColorIndex = 4
         .Font.ColorIndex = 1
            With .Offset(1).Resize(My_count)
              .Value = Application.Transpose(dic.keys)
              .Interior.ColorIndex = 6
            End With
       Else
        .Value = " Not Missing in col " & C
        .Interior.ColorIndex = 5
        .Font.ColorIndex = 2
      End If
    End With
      M = M + 1
   End With
  dic.RemoveAll
 Next
 
 With Sheets("salim")
 .Columns.AutoFit
 .Range("a1").CurrentRegion. _
 SpecialCells(2, 23).Borders.LineStyle = 1
End With
Set dic = Nothing: Set RG = Nothing
End Sub

الملف مرفق

 

 

Small_book.xlsm