Sayısal sıralama diziye alınarak nasıl listelenir ?

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Ekli dosyada A sütununda 1000 adet sayısal değer var. Bu değerler arasındaki benzer olanları E sütununa listelemek istiyorum. Hazırladığım makrolar bu işi yapıyor. Aynı işlemi diziye alma yöntemi ile nasıl çözümleyebilirim. Benzer yoksa mesajla belirtebilir.
Saygılarımla

 

[alicimri]

Merhaba herhalde aşağıdaki gibi bir kod işinizi görür.

Sub a()
For i = 2 To Cells(Cells.Rows.Count, 1).End(3).Row
If WorksheetFunction.CountIf(Range("A:A"), Range("A" & i)) > 1 Then
If WorksheetFunction.CountIf(Range("E:E"), Range("A" & i)) = 0 Then
Range("E" & Cells(Cells.Rows.Count, 5).End(3).Row + 1).Value = Range("A" & i)
End If
End If
Next
End Sub

 

[alicimri]

Dizi konusunu atlamışım

Sub a()
For i = 2 To Cells(Cells.Rows.Count, 1).End(3).Row
If WorksheetFunction.CountIf(Range("A:A"), Range("A" & i)) > 1 Then
If WorksheetFunction.CountIf(Range("E:E"), Range("A" & i)) = 0 Then

Range("E" & Cells(Cells.Rows.Count, 5).End(3).Row + 1).Value = Range("A" & i)
diz = diz & "," & Range("A" & i)
dizi = Split(diz, ",")
End If
End If
Next
End Sub

 

[ÖmerFaruk]

Aşağıdaki kodları kullanabilrsin.

Sub GetirDizi()
Dim Veri, Dizi(), Say As Integer, i As Long, j As Long
    Veri = Range("A1").CurrentRegion.Value
    Set Dict1 = CreateObject("Scripting.Dictionary")
    Set Dict2 = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Veri)
        If Dict1.Count = 0 Or Not Dict1.Exists(Veri(i, 1)) Then
            Dict1.Add Veri(i, 1), 1
        Else
            If Not Dict2.Exists(Veri(i, 1)) Then
                Dict2.Add Veri(i, 1), 1
                Say = Say + 1
                ReDim Preserve Dizi(1 To Say)
                Dizi(Say) = Veri(i, 1)
            End If
        End If
    Next i
    For i = LBound(Dizi) To UBound(Dizi) - 1
        For j = i + 1 To UBound(Dizi)
            If Dizi(i) > Dizi(j) Then
                TempValue = Dizi(i)
                Dizi(i) = Dizi(j)
                Dizi(j) = TempValue
            End If
        Next j
    Next i
    Range("E1").CurrentRegion = ""
    Range("E1").Resize(UBound(Dizi), 1) = Application.Transpose(Dizi)
End Sub

 

[Tevfik_Kursun]

Sayın Arkadaşlarım,
Her ikinize de ayrı ayrı çok teşekkür ederim. Burada benzer olanları listeledik, aynı işlemi benzer olmayanlar için nasıl yapardık?
Saygılarımla

 

[alicimri]

Yine hata yapmışım, gerçi ÖmerFaruk da daha gelişkin bir cevap vermiş.

Sub a()
For i = 2 To Cells(Cells.Rows.Count, 1).End(3).Row
If WorksheetFunction.CountIf(Range("A:A"), Range("A" & i)) > 1 Then
If WorksheetFunction.CountIf(Range("E:E"), Range("A" & i)) = 0 Then

Range("E" & Cells(Cells.Rows.Count, 5).End(3).Row + 1).Value = Range("A" & i)
diz = diz & "," & Range("A" & i)
End If
End If
Next
dizi = Split(diz, ",")
End Sub

 

[Tevfik_Kursun]

Sayın Ali Cimri,
Önemli değil, hepimiz öğreniyoruz.
Yeni soruya cevap ver istersen arkadaşım
İyi çalışmalar

 

[ÖmerFaruk]

Buyrun

Sub GetirDizi_Benzerolmayanlar()
Dim Dict As Object, Veri, Dizi(), Say As Integer, i As Long, j As Long
    Veri = Range("A1").CurrentRegion.Value
    Set Dict = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Veri)
        If Not Dict.Exists(Veri(i, 1)) Then
            Dict.Add Veri(i, 1), 1
        Else
            Dict.Remove Veri(i, 1)
        End If
    Next i
    For Each Key In Dict.Keys
        Say = Say + 1
        ReDim Preserve Dizi(1 To Say)
        Dizi(Say) = Key
    Next Key
    For i = 1 To UBound(Dizi) - 1
        For j = i + 1 To UBound(Dizi)
            If Dizi(i) > Dizi(j) Then
                TempValue = Dizi(i)
                Dizi(i) = Dizi(j)
                Dizi(j) = TempValue
            End If
        Next j
    Next i
    Range("E1").CurrentRegion = ""
    Range("E1").Resize(UBound(Dizi), 1) = Application.Transpose(Dizi)
End Sub

 

[Tevfik_Kursun]

Sayın ÖmerFaruk,
Teşekkür ederim.
Saygılarımla

 

[Haluk]

Alternatif olarak "System.Collections.ArrayList" kullanılabilir;

Not: Bilgisayarda .Net Framework 3.5 olması gerekir....

Sub Test()
    arrData = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)

    Set myList = CreateObject("System.Collections.ArrayList")
  
    For X = 1 To UBound(arrData)
       If Not myList.Contains(arrData(X, 1)) Then myList.Add arrData(X, 1)
    Next
  
    myList.Sort
    Range("E1").Resize(UBound(myList.ToArray) + 1, 1) = Application.Transpose(myList.ToArray)
End Sub

Not: Düzeltme yapıldı...

.

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
Benzer olmayanların listesi 1 eksik geliyor. Bunu düzeltirken, benzer olanların listesini de bu yöntemle verir misiniz, lütfen?
Saygılarımla

 

[Haluk]

1 adet eksik olmaması gerekir.....

Not: 10 No'lu mesajdaki kodda düzeltme yapıldı...

.

 

[Tevfik_Kursun]

Merhaba Haluk Hocam,
1000 tane ile yaptığımda 999
10000 tane ile yaptığımda 9999 geliyor. Ama çok hızlı. Teşekkür ederim
Saygılarımla

 

[Haluk]

O zaman aşağıdaki kodu deneyin, her 2 liste E ve F sütunlarında sıralı olarak listelenecektir;

Sub Test2()
'   Haluk - 10/04/2021
    arrData = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)

    Set myList = CreateObject("System.Collections.ArrayList")
    Set myList2 = CreateObject("System.Collections.ArrayList")
    
    For X = 1 To UBound(arrData)
        If Not myList.Contains(arrData(X, 1)) Then
            myList.Add arrData(X, 1)
        Else
            myList2.Add arrData(X, 1)
        End If
    Next
    
    myList.Sort
    Range("E1").Resize(UBound(myList.ToArray) + 1, 1) = Application.Transpose(myList.ToArray)
    myList2.Sort
    Range("F1").Resize(UBound(myList2.ToArray) + 1, 1) = Application.Transpose(myList2.ToArray)
End Sub

.

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
Evet, şimdi düzgün çalışıyor, küçük bir eklenti yapmak lazım. F1 e yazacak bir şey bulamazsa hata veriyor.
Saygılarımla

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
If myList2.Sort = "" Then Exit Sub
bu eklentiyi yaptım problem bitti. İlginize çok teşekkür ederim.
Saygılarımla

 

[Haluk]

Bahsettiğiniz gibi bir ihtimal varsa, biraz daha düzgün bir revizyon aşağıdaki gibi olabilir;

Sub Test3()
'   Haluk - 10/04/2021
    arrData = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)

    Set myList = CreateObject("System.Collections.ArrayList")
    Set myList2 = CreateObject("System.Collections.ArrayList")
    
    For X = 1 To UBound(arrData)
        If Not myList.Contains(arrData(X, 1)) Then
            myList.Add arrData(X, 1)
        Else
            myList2.Add arrData(X, 1)
        End If
    Next
    
    If myList.Count > 0 Then
        myList.Sort
        Range("E1").Resize(UBound(myList.ToArray) + 1, 1) = Application.Transpose(myList.ToArray)
    End If
    
    If myList2.Count > 0 Then
        myList2.Sort
        Range("F1").Resize(UBound(myList2.ToArray) + 1, 1) = Application.Transpose(myList2.ToArray)
    End If
    
    Set myList2 = Nothing
    Set myList = Nothing
End Sub

.

 

[Tevfik_Kursun]

Sayın Haluk Hocam,
İlginize tekrar teşekkür ederim. Yapmaya çalıştığım 7 basamaklı, birbirinden farklı sayı listesi oluşturmak.
Yeni makroyu da hemen deneyeceğim.
Saygılarımla

 

[Korhan Ayhan]

Konu çözümlenmiş ama çeşitlilik olması açısından ADO kodlamasını paylaşıyorum. Belki kullanmak isteyen olabilir.

Option Explicit

Sub Unique_And_Duplicate_Data_List_Ado()
    Dim My_Connection As Object, My_Recordset As Object
    Dim My_Query As String, Process_Time As Double
    
    Process_Time = Timer
    
    Range("E:F").Clear
    
    Set My_Connection = VBA.CreateObject("AdoDb.Connection")
    Set My_Recordset = VBA.CreateObject("AdoDb.Recordset")
    
    My_Connection.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
     
    My_Query = "Select Distinct F1 From [Sayfa1$] Group By F1 Having Count(F1) > 1 Order By F1 Asc"
    
    My_Recordset.Open My_Query, My_Connection, 1, 1
    
    If My_Recordset.RecordCount > 0 Then
        Range("E1") = "Tekrar Edenler"
        Range("E1").Font.Bold = True
        Range("E1").Font.Color = vbRed
        Range("E1").HorizontalAlignment = xlCenter
        Range("E2").CopyFromRecordset My_Recordset
    End If
    
    If My_Recordset.State <> 0 Then My_Recordset.Close
    
    
    My_Query = "Select Distinct F1 From [Sayfa1$] Group By F1 Having Count(F1) = 1 Order By F1 Asc"
    
    My_Recordset.Open My_Query, My_Connection, 1, 1
    
    If My_Recordset.RecordCount > 0 Then
        Range("F1") = "Tekrar Etmeyenler"
        Range("F1").Font.Bold = True
        Range("F1").Font.Color = vbRed
        Range("F1").HorizontalAlignment = xlCenter
        Range("F2").CopyFromRecordset My_Recordset
    End If
    
    If My_Recordset.State <> 0 Then My_Recordset.Close
    
    Columns.AutoFit
  
    If My_Connection.State <> 0 Then My_Connection.Close
  
    Set My_Connection = Nothing
    Set My_Recordset = Nothing
  
    MsgBox "Tekrar eden ve tekrar etmeyen veriler listelenmiştir." & vbCrLf & vbCrLf & _
           "İşlem süresi ; " & Format(Timer - Process_Time, "0.00") & " Saniye"
End Sub

 

[Tevfik_Kursun]

Sayın Korhan Hocam,
İlginize teşekkür ederim. Konuya cevap veren her arkadaşım bende farklı düşünceler uyandırdı, hepinize tekrar teşekkür ederim.
Bir kaç gündür çok basamaklı sayılar üzerinde çalışıyorum. Dünden beri farklı sayıları temin edip listelemede çok değişik yöntemler öğrendim, geliştirdim ve kullandım. Sizin çalışma, beni bir daha konuya bakmaya iştahlandırdı ve bir takım sorulara cevap aramaya yönlendirdi. Aşağıdaki sorulara cevap vermek zorunda değilsiniz, ama verirseniz çok farklı bakış açıları elde edeceğimden kesinlikle eminim.

ADO olduğu için mi 1. sütundan alıyor?
Değerleri 10. sütundan alması için ne gerekir?
Benzeri olanı If My_Recordset.RecordCount > 0 Then anladığım kadarı ile, bu bölümde tespit ediyor?
Benzer olanı tespit ettiğinde, o hücredeki sayıyı nasıl 1 arttırabilir?

Saygılarımla