benzersiz kayıtları makro ile listeleme

[NADİR YILDIZ]

arkadaşlar sarı alandaki ünvanlardan benzersiz olanları yeni listeye harf sırasına göre makro ile nasıl aktarabiliriz ?

 

[Muzaffer Ali]

Merhaba.

Aşağıdaki kodları kullanabilirsiniz.

Sub Test()
    Range("C1:C" & Cells(Rows.Count, "C").End(xlUp).Row).Copy Range("E1")
    Range("E:E").RemoveDuplicates Columns:=1, Header:=xlYes
End Sub

 

[NADİR YILDIZ]

Teşekkürler sayın Dalgalikur

iyi bayramlar

 

[Muzaffer Ali]

Rica ederim. İyi bayramlar.

 

[TUNCA ERSİN]

buna bir adet koşul nasıl koya biliriz.

 

[Korhan Ayhan]

Koşul nedir?

 

[TUNCA ERSİN]

Sy. @Korhan Ayhan ;
Hocam Taşıma Liste sayfasından A3 den itibaren A500 kadar firmalar var ama sayısı değişiyor.

B sütununda ise Plakalar var , benim istediğim Liste sayfası A1 de seçtiğim firmaya ait araçları A3 den itibaren benzersiz listelemesi. Taşıma Liste listesi C sütunun da ise ücreti var onu da Liste sayfası B3 den itibaren değerini getirmesi.

Sizden ricam Kodlara açıklama yazarsanız sevinirim , sebebi ise Bu listeleme I sütununa kadar devam etmektedir. iyi günler.

 

[Korhan Ayhan]

Örnek dosya paylaşarak talebinizi yineleyiniz.

 

[TUNCA ERSİN]

Sy. @Korhan Ayhan ;
buyurunuz.

 

[Korhan Ayhan]

Aşağıdaki formülle sonuca gidebilirsiniz.

DİZİ Formüldür. Eğer Türkçe sürüm kullanıyorsanız formülü çevirmeniz gerekir.

=IFERROR(INDEX(Tablo4[Plaka];MATCH(0;IF(Tablo4[Mülkiyet]=$A$1;COUNTIF(Liste!B$2:B2;Tablo4[Plaka]));0));"")

 

[TUNCA ERSİN]

Sy. @Korhan Ayhan ;
Hocam verilerim çok fazla olduğu için tabloları aralığa dönüştürsem. Formülü de kod' a çevirsek hızlanır mı ? baya bir şekilde yavaşladı.
aynı zaman da büyükten küçüğe sıralama yaptığım zaman ise hata vermekte.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Unique_List()
    Dim S1 As Worksheet, S2 As Worksheet, Unique_List As Object, My_Data As Variant, X As Long
   
    Set S1 = Sheets("Taşıma Liste")
    Set S2 = Sheets("Liste")
    Set Unique_List = VBA.CreateObject("Scripting.Dictionary")
   
    My_Data = S1.ListObjects("Tablo4").ListColumns(1).DataBodyRange.Resize(, 2).Value
   
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If My_Data(X, 1) = S2.Range("A1") Then
            If Not Unique_List.Exists(My_Data(X, 2)) Then
                Unique_List.Add My_Data(X, 2), False
            End If
        End If
    Next
   
    S2.ListObjects("Tablo5").ListColumns(2).DataBodyRange.ClearContents
    S2.ListObjects("Tablo5").ListColumns(2).DataBodyRange.Cells(1, 1).Resize(Unique_List.Count) = Application.Transpose(Unique_List.Keys)
   
    Erase My_Data
   
    Set S1 = Nothing
    Set S2 = Nothing
    Set Unique_List = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Eğer veri sayısı 65536 satırı geçiyorsa yukarıdaki önerim büyük ihtimalle hata verecektir. Alternatif olarak aşağıdaki kodu deneyebilirsiniz.

Option Explicit

Sub Unique_List()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Unique_List As Object, My_Data As Variant
    Dim Count_Data As Long, X As Long
    
    Set S1 = Sheets("Tasima Liste")
    Set S2 = Sheets("Liste")
    Set Unique_List = VBA.CreateObject("Scripting.Dictionary")
    
    My_Data = S1.ListObjects("Tablo4").ListColumns(1).DataBodyRange.Resize(, 2).Value
    
    ReDim My_List(1 To UBound(My_Data, 1), 1 To 1)
    
    For X = LBound(My_Data, 1) To UBound(My_Data, 1)
        If My_Data(X, 1) = S2.Range("A1") Then
            If Not Unique_List.Exists(My_Data(X, 2)) Then
                Unique_List.Add My_Data(X, 2), False
                Count_Data = Count_Data + 1
                My_List(Count_Data, 1) = My_Data(X, 2)
            End If
        End If
    Next
    
    S2.ListObjects("Tablo5").ListColumns(2).DataBodyRange.ClearContents
    S2.ListObjects("Tablo5").ListColumns(2).DataBodyRange.Cells(1, 1).Resize(Unique_List.Count) = My_List
    
    Erase My_Data
    Erase My_List
    
    Set S1 = Nothing
    Set S2 = Nothing
    Set Unique_List = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[TUNCA ERSİN]

Sy. @Korhan Ayhan ;
İlginiz için teşekkür ederim. iki kod da aynı şekilde çalışıyor. Ellerinize sağlık. Allah c.c. razı olsun.

 

[KİMSESİZ YAŞAR]

bu benzersiz formülünü excel 2019da kullanamıyor muyuz?