Aynı kayıtları saydırma

[sldrkyurdal]

Merhaba ,
Excel listemde markalar var yanlarında ise sayılar . Yapmak istediğim örneğin , Arçelik firmasının karşısında yazan numaralari saydırmak yani iki farklı numara var ise sayfa 2 ye firmanın karşısına 2 yazmak gibi. Desteğiniz için çok teşekkürler

 

[Seceren]

Örneği drive dan paylaşırsanız bakmak isterim. Çözme garantisi veremiyorum... (¬‿¬)

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Firma_Say()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Son As Long
    Dim Veri As Variant, X As Long, Say As Long, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
    
    Veri = S1.Range("A1:B" & Son).Value
    
    ReDim Liste(1 To Son, 1 To 2)
    
    For X = LBound(Veri) To UBound(Veri)
        If Not Dizi.Exists(Veri(X, 1)) Then
            Say = Say + 1
            Dizi.Add Veri(X, 1), Veri(X, 2)
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = 1
        Else
            If Dizi.Item(Veri(X, 1)) <> Veri(X, 2) Then
                Liste(Dizi.Item(Veri(X, 1)), 2) = Liste(Dizi.Item(Veri(X, 1)), 2) + 1
            End If
        End If
    Next
    
    S2.Range("A:B").ClearContents
    S2.Range("A1").Resize(Dizi.Count, 2) = Liste
    S2.Columns.AutoFit

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[sldrkyurdal]

Deneyiniz.

Option Explicit

Sub Firma_Say()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Son As Long
    Dim Veri As Variant, X As Long, Say As Long, Zaman As Double
   
    Zaman = Timer
   
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set Dizi = CreateObject("Scripting.Dictionary")
   
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
   
    Veri = S1.Range("A1:B" & Son).Value
   
    ReDim Liste(1 To Son, 1 To 2)
   
    For X = LBound(Veri) To UBound(Veri)
        If Not Dizi.Exists(Veri(X, 1)) Then
            Say = Say + 1
            Dizi.Add Veri(X, 1), Veri(X, 2)
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = 1
        Else
            If Dizi.Item(Veri(X, 1)) <> Veri(X, 2) Then
                Liste(Dizi.Item(Veri(X, 1)), 2) = Liste(Dizi.Item(Veri(X, 1)), 2) + 1
            End If
        End If
    Next
   
    S2.Range("A:B").ClearContents
    S2.Range("A1").Resize(Dizi.Count, 2) = Liste
    S2.Columns.AutoFit

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Merhaba ,

Liste(Dizi.Item(Veri(X, 1)), 2) = Liste(Dizi.Item(Veri(X, 1)), 2) + 1

Kalabalık data Yukarı daki kodda hata alıyor nedenini anlamadım bazen de eksik sayıyor. Teşekkürler

 

[Korhan Ayhan]

Hata veren dosyayı paylaşırsanız sebebini inceleme fırsatımız olur.

 

[izcik]

Deneyiniz.

Option Explicit

Sub Firma_Say()
    Dim S1 As Worksheet, S2 As Worksheet, Dizi As Object, Son As Long
    Dim Veri As Variant, X As Long, Say As Long, Zaman As Double
  
    Zaman = Timer
  
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    Set Dizi = CreateObject("Scripting.Dictionary")
  
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    If Son = 2 Then Son = 3
  
    Veri = S1.Range("A1:B" & Son).Value
  
    ReDim Liste(1 To Son, 1 To 2)
  
    For X = LBound(Veri) To UBound(Veri)
        If Not Dizi.Exists(Veri(X, 1)) Then
            Say = Say + 1
            Dizi.Add Veri(X, 1), Veri(X, 2)
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = 1
        Else
            If Dizi.Item(Veri(X, 1)) <> Veri(X, 2) Then
                Liste(Dizi.Item(Veri(X, 1)), 2) = Liste(Dizi.Item(Veri(X, 1)), 2) + 1
            End If
        End If
    Next
  
    S2.Range("A:B").ClearContents
    S2.Range("A1").Resize(Dizi.Count, 2) = Liste
    S2.Columns.AutoFit

    Set S1 = Nothing
    Set S2 = Nothing
    Set Dizi = Nothing

    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan Ayhan uzmanım
Bu kodlar aynı zamanda güzel bir mükerrer dosyası olmuş oldu.

Şöyle ki,

Eğer Sayfa 1 de A sütunundaki verilerin yanına B sütununa sadece 1 rakamını koyarsak veya B sütununu boş bırakırsak;
Sayfa 2 ye mükerrerleri eleyip 1er tanelik neticeyi veriyor.


Eğer Sayfa 1 de A sütunundaki verilerin yanına B sütununa 1 den itibaren rakamları ardışık girersek; o zaman da hem neticeyi veriyor hem de tekrar edenlerin sayısını gösteriyor.

Denemelerle tespit ettim.

Yani iki işe birden yarıyor verdiğiniz kodlar.

Sadece 1. satırlar başlık olacağından 1. satırları kodlarda silmeye ve A2 den başlatmaya çalışacağım. Umarım doğru yapabilirim.

 

[izcik]

Korhan Ayhan uzmanım
Bu kodlar aynı zamanda güzel bir mükerrer dosyası olmuş oldu.

Şöyle ki,

Eğer Sayfa 1 de A sütunundaki verilerin yanına B sütununa sadece 1 rakamını koyarsak veya B sütununu boş bırakırsak;
Sayfa 2 ye mükerrerleri eleyip 1er tanelik neticeyi veriyor.


Eğer Sayfa 1 de A sütunundaki verilerin yanına B sütununa 1 den itibaren rakamları ardışık girersek; o zaman da hem neticeyi veriyor hem de tekrar edenlerin sayısını gösteriyor.

Denemelerle tespit ettim.

Yani iki işe birden yarıyor verdiğiniz kodlar.

Sadece 1. satırlar başlık olacağından 1. satırları kodlarda silmeye ve A2 den başlatmaya çalışacağım. Umarım doğru yapabilirim.

Uzmanım bu kodlar aynı zamanda müthiş hızlı

24419 satırlık karışık isim (ad soyad vs) listesini
0,15 saniyede (saniyenin dörtte biri)
5294 satırlık 1 erli elenmiş sadeleşmiş haline dönüştürdü
**
Yine aynı listeyi 5294 satırlık (yanında mükerrer tekrarları gösterecek şekilde) hal, sadece 0,24 saniyede dönüştürdü.
Saniyenin yarısı bile olmadı.

Bu listeyle daha önceden; eğerhata, indis gibi formüllerle denemeler yapıyordum. Daha ilk satırda excel donuyordu.

Uzun lafın kısası yine mükemmel bir kod paylaştınız uzmanım.