Çözüldü Belirli Aralıktaki Olmayan Sayıları Tespit Etme?

[sitki1]

Merhaba,

Örnek dosyamız ektedir. A ve B alanlarından oluşan bir dosyamız var. A sütununda ki aynı isme sahip kişilerin B sütunundaki sayılara göre boş sayılarını tespit etmek istiyoruz. B sütununda ki sayıların aralığı 0-15.

Örneğin A sütununda ki;
Ali için talep ettiğimiz 0-15 aralıktaki boş olan "4-10-11-12" değerlerini getirmesini istiyoruz.
Veli için talep ettiğimiz 0-15 aralıktaki boş olan "0-1-2-3-4-5-6-7-8-9-13-14" değerlerini getirmesini istiyoruz.
Osman için talep ettiğimiz 0-15 aralıktaki boş olan "2-6-7-8-9-10-11-12-13-14-15" değerlerini getirmesini istiyoruz.

Bu değerleri listenin altına işleyeceğiz.

Yardımlarınızı rica ederiz.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Find_Missing_Numbers()
    Dim Rng As Range, Search_Data As String
    Dim My_Array_1 As Object, My_Array_2 As Object
    Dim Name_Item As Variant, X As Long, Y As Long
    
    Set My_Array_1 = VBA.CreateObject("Scripting.Dictionary")
    Set My_Array_2 = VBA.CreateObject("Scripting.Dictionary")
        
    For Each Rng In Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
        Search_Data = Rng.Value
        If Not My_Array_1.Exists(Search_Data) Then
            My_Array_1.Add Search_Data, False
        End If
        
        Search_Data = Rng.Value & "#" & Rng.Offset(, 1).Value
        If Not My_Array_2.Exists(Search_Data) Then
            My_Array_2.Add Search_Data, False
        End If
    Next
    
    ReDim My_List(1 To Rows.Count, 1 To 2)
    
    For Each Name_Item In My_Array_1
        For X = 0 To 15
            If Not My_Array_2.Exists(Name_Item & "#" & X) Then
                Y = Y + 1
                My_List(Y, 1) = Name_Item
                My_List(Y, 2) = X
            End If
        Next
    Next

    If Y > 0 Then
        Cells(Rows.Count, 1).End(3).Offset(1).Resize(Y, 2) = My_List
        MsgBox "Tespit edilen eksik sayı serileri listenin altına eklenmiştir.", vbInformation
    Else
        MsgBox "Eksik sayı serisi bulunmadı!", vbExclamation
    End If
End Sub

 

[sitki1]

Üstad eline sağlık, teşekkürler.

Deneyiniz.

Option Explicit

Sub Find_Missing_Numbers()
    Dim Rng As Range, Search_Data As String
    Dim My_Array_1 As Object, My_Array_2 As Object
    Dim Name_Item As Variant, X As Long, Y As Long
   
    Set My_Array_1 = VBA.CreateObject("Scripting.Dictionary")
    Set My_Array_2 = VBA.CreateObject("Scripting.Dictionary")
       
    For Each Rng In Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
        Search_Data = Rng.Value
        If Not My_Array_1.Exists(Search_Data) Then
            My_Array_1.Add Search_Data, False
        End If
       
        Search_Data = Rng.Value & "#" & Rng.Offset(, 1).Value
        If Not My_Array_2.Exists(Search_Data) Then
            My_Array_2.Add Search_Data, False
        End If
    Next
   
    ReDim My_List(1 To Rows.Count, 1 To 2)
   
    For Each Name_Item In My_Array_1
        For X = 0 To 15
            If Not My_Array_2.Exists(Name_Item & "#" & X) Then
                Y = Y + 1
                My_List(Y, 1) = Name_Item
                My_List(Y, 2) = X
            End If
        Next
    Next

    If Y > 0 Then
        Cells(Rows.Count, 1).End(3).Offset(1).Resize(Y, 2) = My_List
        MsgBox "Tespit edilen eksik sayı serileri listenin altına eklenmiştir.", vbInformation
    Else
        MsgBox "Eksik sayı serisi bulunmadı!", vbExclamation
    End If
End Sub

 

[veyselemre]

Alternatif olsun;

Sub test()
    Dim lst, ky, kys, i&, say&
    lst = Range("A2:B" & Cells(Rows.Count, 2).End(3).Row).Value

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(lst)
            .Item("_" & lst(i, 1)) = lst(i, 1)
            .Item(lst(i, 1) & "|" & lst(i, 2)) = Null
        Next
        kys = Filter(.keys, "_")
        ReDim lst(1 To (UBound(kys) + 1) * 16, 1 To 2)
        For Each ky In kys
            ky = .Item(ky)
            For i = 0 To 15
                If Not .exists(ky & "|" & i) Then
                    say = say + 1
                    lst(say, 1) = ky
                    lst(say, 2) = i
                End If
            Next i
        Next ky
    End With

    If say > 0 Then Range("D2").Resize(say, 2).Value = lst

End Sub

 

[sitki1]

Süpersiniz, çok teşekkürler üstad.

Alternatif olsun;

Sub test()
    Dim lst, ky, kys, i&, say&
    lst = Range("A2:B" & Cells(Rows.Count, 2).End(3).Row).Value

    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(lst)
            .Item("_" & lst(i, 1)) = lst(i, 1)
            .Item(lst(i, 1) & "|" & lst(i, 2)) = Null
        Next
        kys = Filter(.keys, "_")
        ReDim lst(1 To (UBound(kys) + 1) * 16, 1 To 2)
        For Each ky In kys
            ky = .Item(ky)
            For i = 0 To 15
                If Not .exists(ky & "|" & i) Then
                    say = say + 1
                    lst(say, 1) = ky
                    lst(say, 2) = i
                End If
            Next i
        Next ky
    End With

    If say > 0 Then Range("D2").Resize(say, 2).Value = lst

End Sub