Makro İle Benzersizleri Saydırma

[ttnetttnet]

Merhabalar,

Ekteki dosyada, belli bir sütundaki değerlerin benzersiz olanlarını saydırmak ile ilgili bir sorum olacak. Bunu makro ile yapmak istiyorum. Satır sayısı fazla olduğu için formül ile çok yavaşlatıyor dosyayı.

Yardımınız için teşekkürler.
Saygılarımla,

 

[Murat OSMA]

Merhaba,

Bu kodları kullanabilirsiniz;

[FONT="Trebuchet MS"][SIZE="2"]Sub Emre()
    With CreateObject("[COLOR="Red"]Scripting.Dictionary[/COLOR]")
        For i = 13 To 30
            If Not .[COLOR="red"]exists[/COLOR](Cells(i, "I").Value) Then
                .[COLOR="red"]Item[/COLOR](Cells(i, "I").Value) = [COLOR="blue"]1[/COLOR]
                    Else
                .[COLOR="red"]Item[/COLOR](Cells(i, "I").Value) = .[COLOR="red"]Item[/COLOR](Cells(i, "I").Value) [COLOR="Blue"]+ 1[/COLOR]
            End If
        Next i
       Range("CO3").Value = .[COLOR="red"]Count - 1[/COLOR]
    End With
End Sub[/SIZE][/FONT]

Ya da bu kodları;

[FONT="Trebuchet MS"][SIZE="2"]Sub Emre()
    Dim i%, say%
    For i = 13 To 30
        If WorksheetFunction.[COLOR="Red"]CountIf[/COLOR](Range("I13:I" & i), Cells(i, "I").Value) [COLOR="Red"]= 1[/COLOR] Then say = say + 1
    Next i
    Range("CO3").Value = say
    say = Empty: i = Empty
End Sub[/SIZE][/FONT]

 

[ttnetttnet]

Merhaba,

Bu kodları kullanabilirsiniz;

[FONT="Trebuchet MS"][SIZE="2"]Sub Emre()
    With CreateObject("[COLOR="Red"]Scripting.Dictionary[/COLOR]")
        For i = 13 To 30
            If Not .[COLOR="red"]exists[/COLOR](Cells(i, "I").Value) Then
                .[COLOR="red"]Item[/COLOR](Cells(i, "I").Value) = [COLOR="blue"]1[/COLOR]
                    Else
                .[COLOR="red"]Item[/COLOR](Cells(i, "I").Value) = .[COLOR="red"]Item[/COLOR](Cells(i, "I").Value) [COLOR="Blue"]+ 1[/COLOR]
            End If
        Next i
       Range("CO3").Value = .[COLOR="red"]Count - 1[/COLOR]
    End With
End Sub[/SIZE][/FONT]

Ya da bu kodları;

[FONT="Trebuchet MS"][SIZE="2"]Sub Emre()
    Dim i%, say%
    For i = 13 To 30
        If WorksheetFunction.[COLOR="Red"]CountIf[/COLOR](Range("I13:I" & i), Cells(i, "I").Value) [COLOR="Red"]= 1[/COLOR] Then say = say + 1
    Next i
    Range("CO3").Value = say
    say = Empty: i = Empty
End Sub[/SIZE][/FONT]

Çok teşekkürler Murat Bey, bu makronun herhangi başka hücrenin seçilmesiyle çalışmasını sağlayabilir miyiz?

 

[Erdem Akdemir]

Merhaba,

Tag'daki kodu kullanabilirsiniz.
Msgbox yerine kendi istediğiniz hücre'yi yazın.

Sub Emre()
With CreateObject("Scripting.Dictionary")
Set hcr = Application.InputBox("hücreler", "Alanı Seçiniz", Type:=8)
For Each alan In hcr
If Not .exists(alan.Value) Then
.Item(alan.Value) = 1
End If
Next
MsgBox .Count
End With
End Sub

 

[Erdem Akdemir]

Alternatif,

Sub deneme()
Set hcr = Application.InputBox("hücreler", "Alanı Seçiniz", Type:=8)
With CreateObject("ADODB.Recordset")
.Open "select count(deger) from (select distinct f1 as deger from[" & ActiveSheet.Name & "$" & hcr.Address(0, 0) & "])", "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=no"""
'MsgBox rs.Fields.Item(0).Value
MsgBox .Fields.Item(0).Value
End With