• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

a2:a1000 aralığındaki benzersiz kayıtları diziye almak

H

hsayar

Katılım
2 Mart 2005
Mesajlar
2,960
Excel Vers. ve Dili
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
a2:a1000 aralığındaki benzersiz kayıtları diziye almak nasıl mümkün olur?
 
hocam teşekkür ederim yarın inceleyecem ama amacımıda söyleyeyim
Sayfa1!a2:a1000 aralığındaki benzersizleri diziye alıp,

Sayfa2 nin 50 satırın 4 sütunu ila 50 satırın 4 + (benzersizkayıt sayısı) nolu sütununa yerleştirmek yarın vakit bulursam kafa patlatırım... ama siz lütfederseniz sevinirim.

yani Advancedfilter a arrkadan dolaşarak transpose özelliği katmak

TransposeAdvFilter(Verilerin Alıncağı Erim;Verilerin yapıştırılacağı başlangıçhücresi) şeklinde yazılacak mümkünse büyük küçük harf duyarsız olsun.. (ali, Ali, ALİ, aLi) hepsi aynı
 
aklıma gelid büyük küçük harf işini hallettim...
geriye başalngıç hücresinden itibaren for next ile yana doğru yazmak kaldı inşallah halledebilirim... ama siz halledersenizde hayır diyemem

Kod: 
Option Explicit
Function CARİ(Aralik As Range, Sira As Integer)
Dim hcr As Range
Dim arrVeri()
Dim i&, j&, x&, y&
For Each hcr In Aralik.Cells
    i = i + 1
    If i = 1 Then
       ReDim Preserve arrVeri(y)
       arrVeri(y) = ucasetr(hcr)
    Else
       For j = 0 To UBound(arrVeri)
           If ucasetr(hcr) = arrVeri(j) Then: x = x + 1
       Next j
       If x = 0 Then
          y = y + 1
          ReDim Preserve arrVeri(y)
          arrVeri(y) = ucasetr(hcr)
       End If
       x = 0
    End If
Next
CARİ = arrVeri(Sira - 1)
End Function

Kod: 
Function UCaseTr(ByVal metin As String)
    UCaseTr = UCase(Replace(Replace(metin, "ı", "I"), "i", "İ"))
End Function
 
Hocam Fonksiyonunuzla biraz değişiklik yapınca sonuca ulaştım.

Değer Hatası dönmesin diye koyduğum kontrolde mantık hatası yapmışım hocam özür dilerim.

Kod: 
Function Benzersiz_Kayit(Aralik As Range, Sira As Integer, _
                    Optional ByVal Kayıtlar As Boolean = True)
'Elemanları hücreye yazmak için
    'VBA   da    : Benzersiz_Kayit(Aralik, i + 1) şeklinde kullanmalısınız. Sırano 1 den başlar.
    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;SATIR()-1) şeklinde kullanabilirsiniz.
''Eleman sayısını öğrenmek için
    'VBA   da    : Benzersiz_Kayit(Aralik, 1, False) şeklinde kullanmalısınız. Sıra no olarak 1 kullanın
    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;1;0) şeklinde kullanbilirsiniz.
Dim hcr As Range
Dim arrVeri()
Dim i&, j&, x&, y&
For Each hcr In Aralik.Cells
    i = i + 1
    If i = 1 Then
       ReDim Preserve arrVeri(y)
       arrVeri(y) = ucasetr(hcr)
    Else
       For j = 0 To UBound(arrVeri)
           If ucasetr(hcr) = arrVeri(j) Then: x = x + 1
       Next j
       If x = 0 Then
          y = y + 1
          ReDim Preserve arrVeri(y)
          arrVeri(y) = ucasetr(hcr)
       End If
       x = 0
    End If
Next
If Kayıtlar = True Then
    If Sira[COLOR=red] - 1[/COLOR] > UBound(arrVeri) Then
        Benzersiz_Kayit = ""
    Else
        Benzersiz_Kayit = arrVeri(Sira - 1)
    End If
Else
    Benzersiz_Kayit = UBound(arrVeri)
End If
End Function

Kod: 
Function UCaseTr(ByVal metin As String)
    UCaseTr = UCase(Replace(Replace(metin, "ı", "I"), "i", "İ"))
End Function

Kod: 
Sub SütunaBenzersizYaz()
Dim intTopEl%, i%
 
Dim buKtp       As Workbook:        Set buKtp = ThisWorkbook
Dim Syf_T       As Worksheet:       Set Syf_T = buKtp.Worksheets("Sayfa3")
Dim Aralik      As Range:
 
Set Aralik = Syf_T.Range("c3:c23")
'Aralık olarak Verileirmizin bulunduğu Sayfa3 ün c3:c22 aralığını seçmemiz gerekiyor ama _
nedense öyle yapınca doğru sonuç vermediği için  c3:c23 aralığını seçiyoruz.
 
intTopEl = Benzersiz_Kayit(Aralik, 1, False)   'Benzersiz Kayıt sayısını öğrendik
For i = 0 To intTopEl - 1                       '0 dan son elamana kadar döngü kurduk
    Syf_T.Cells(2, i + 8).Value = Benzersiz_Kayit(Aralik, i + 1)
    'Sayfa3 ün 2 satırı ile (i + 8). hücresi yani 0 için h den başlayarak elemanları satıra yazdık.
Next i  'döngü bitti.
 
Set buKtp = Nothing
Set Syf_T = Nothing
Set Aralik = Nothing
End Sub
 
Son düzenleme:
.......hallettim.
 
Son düzenleme:
Kısaca sorun Aralik = B3: D10 ise d10 u elaman olarak saymamasıdır. hocam?
5 nolu mesajda sizin fonksiyonunuzu kendime uyarladım.
6 nolu mesajda Aralığı makro içinde tanımlayıp benzersizleri fornext ile e3 ten sona kadart yaz dedim?
ama d10 benzertsiz kayıt olmasına rağmen d10 u almadı ama b10 ve c10 u yazdı.
çıktı listeside zaten 6.mesajda mevcuttur.
 
Değer Hatası dönmesin diye koydupum kontreolde mantık hatası yapmışım hocam özür dilerim.

Kod: 
Function Benzersiz_Kayit(Aralik As Range, Sira As Integer, _
                    Optional ByVal Kayıtlar As Boolean = True)
'Elemanları hücreye yazmak için
    'VBA   da    : Benzersiz_Kayit(Aralik, i + 1) şeklinde kullanmalısınız. Sırano 1 den başlar.
    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;SATIR()-1) şeklinde kullanabilirsiniz.
''Eleman sayısını öğrenmek için
    'VBA   da    : Benzersiz_Kayit(Aralik, 1, False) şeklinde kullanmalısınız. Sıra no olarak 1 kullanın
    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;1;0) şeklinde kullanbilirsiniz.
Dim hcr As Range
Dim arrVeri()
Dim i&, j&, x&, y&
For Each hcr In Aralik.Cells
    i = i + 1
    If i = 1 Then
       ReDim Preserve arrVeri(y)
       arrVeri(y) = ucasetr(hcr)
    Else
       For j = 0 To UBound(arrVeri)
           If ucasetr(hcr) = arrVeri(j) Then: x = x + 1
       Next j
       If x = 0 Then
          y = y + 1
          ReDim Preserve arrVeri(y)
          arrVeri(y) = ucasetr(hcr)
       End If
       x = 0
    End If
Next
If Kayıtlar = True Then
    If Sira - 1 > UBound(arrVeri) Then
        Benzersiz_Kayit = ""
    Else
        Benzersiz_Kayit = arrVeri(Sira - 1)
    End If
Else
    Benzersiz_Kayit = UBound(arrVeri)
End If
End Function

Kod: 
[LEFT]Function UCaseTr(ByVal metin As String)
    UCaseTr = UCase(Replace(Replace(metin, "ı", "I"), "i", "İ"))
End Function
[/LEFT]
 
Son düzenleme:
Kod: 
Option Explicit[/FONT]
[FONT=Courier New]Function Benzersiz_Kayıtlar(Aralik As Range, Sira As Integer, _[/FONT]
[FONT=Courier New]                    Optional ByVal Kayıtlar As Boolean = True)[/FONT]
[FONT=Courier New]'Sn. Ferhat Pazarçevirdi ve Sn. Veysel Emrenin Bilgilerinden derlenmiştir.[/FONT]
[FONT=Courier New]'Yazar: HSayar-Excel.web.tr[/FONT]
[FONT=Courier New]'Elemanları hücreye yazmak için[/FONT]
[FONT=Courier New]    'VBA   da    : Benzersiz_Kayit(Aralik, i) şeklinde kullanmalısınız. Sırano 1 den başlar.[/FONT]
[FONT=Courier New]    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;SATIR()-1) şeklinde kullanabilirsiniz.[/FONT]
[FONT=Courier New]''Eleman sayısını öğrenmek için[/FONT]
[FONT=Courier New]    'VBA   da    : Benzersiz_Kayit(Aralik, 1, False) şeklinde kullanmalısınız. Sıra no olarak 1 kullanın[/FONT]
[FONT=Courier New]    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;1;0) şeklinde kullanbilirsiniz.[/FONT]
[FONT=Courier New]Dim y&, z&[/FONT]
[FONT=Courier New]Dim arrVeri(), colVeri, Ara         As Variant[/FONT]
[FONT=Courier New]Dim col                             As New Collection[/FONT]
[FONT=Courier New][/FONT] 
[FONT=Courier New]'Bir Hücre Aralığını Diziye Al====================================================================='\\[/FONT]
[FONT=Courier New]arrVeri = Aralik.Value                                                                              'II[/FONT]
[FONT=Courier New]'__________________________________________________________________________________________________'//[/FONT]
[FONT=Courier New][/FONT] 
[FONT=Courier New]'ArrVerideki Benzersiz Kayıtları Koleksiyona Al===================================================='\\[/FONT]
[FONT=Courier New]On Error Resume Next                                            'Değer koleksiyona alınmışsa diğerine geç[/FONT]
[FONT=Courier New]For Each colVeri In arrVeri                                     'Dizideki Benzersizleri[/FONT]
[FONT=Courier New]    If colVeri <> "" Then col.Add colVeri, (Format(colVeri, "@"))[/FONT]
[FONT=Courier New]Next                                                            'Diğer elamana geç[/FONT]
[FONT=Courier New]On Error GoTo 0                                                 'Hata olursa söyle[/FONT]
[FONT=Courier New]'__________________________________________________________________________________________________'//[/FONT]
[FONT=Courier New]'ArrVeriyi yeniden oluştur.========================================================================'\\[/FONT]
[FONT=Courier New]ReDim arrVeri(1 To col.Count)                                                                      'II[/FONT]
[FONT=Courier New]For y = 1 To col.Count:         arrVeri(y) = UCaseTr(col(y)):    Next y                            'II[/FONT]
[FONT=Courier New]Set col = Nothing:              y = 0                                                              'II[/FONT]
[FONT=Courier New]'__________________________________________________________________________________________________'//[/FONT]
[FONT=Courier New]'Sırala (0 dan Z'ye================================================================================'\\[/FONT]
[FONT=Courier New]For y = 1 To UBound(arrVeri) - 1                                                                   'II[/FONT]
[FONT=Courier New]    For z = y + 1 To UBound(arrVeri)                                                               'II[/FONT]
[FONT=Courier New]        If StrComp(arrVeri(y), arrVeri(z), vbTextCompare) = 1 Then                                 'II[/FONT]
[FONT=Courier New]            Ara = arrVeri(y)                                                                       'II[/FONT]
[FONT=Courier New]            arrVeri(y) = arrVeri(z)                                                                'II[/FONT]
[FONT=Courier New]            arrVeri(z) = Ara                                                                       'II[/FONT]
[FONT=Courier New]        End If                                                                                     'II[/FONT]
[FONT=Courier New]    Next                                                                                           'II[/FONT]
[FONT=Courier New]Next                                                                                               'II[/FONT]
[FONT=Courier New]Set Ara = Nothing:              y = 0:                           z = 0                             'II[/FONT]
[FONT=Courier New]'__________________________________________________________________________________________________'//[/FONT]
[FONT=Courier New]'Sonucu Hücreye veya değişkene ver '==============================================================='\\[/FONT]
[FONT=Courier New]If Kayıtlar = True Then                                                                            'II[/FONT]
[FONT=Courier New]    If Sira > UBound(arrVeri) Then                                                                 'II[/FONT]
[FONT=Courier New]        Benzersiz_Kayıtlar = ""                                                                    'II[/FONT]
[FONT=Courier New]    Else                                                                                           'II[/FONT]
[FONT=Courier New]        Benzersiz_Kayıtlar = arrVeri(Sira)                                                         'II[/FONT]
[FONT=Courier New]    End If                                                                                         'II[/FONT]
[FONT=Courier New]Else                                                                                               'II[/FONT]
[FONT=Courier New]    Benzersiz_Kayıtlar = UBound(arrVeri)                                                           'II[/FONT]
[FONT=Courier New]End If                                                                                             'II[/FONT]
[FONT=Courier New]'__________________________________________________________________________________________________'//[/FONT]
[FONT=Courier New]End Function

Değerli hocalarım bu fonksiyonu bugüne kadar kullanıyortdum ama olmayacak bir şey çıktı şimdi şöyle

Kod: 
 [/FONT]
[FONT=Courier New]TablomYillarSonSat = shT.Cells(65536, "b").End(3).Row                                                '||[/FONT]
[FONT=Courier New][/FONT] 
[FONT=Courier New]BY_Sayisi = Benzersiz_Kayıtlar(shT.Range("A2:A" & TablomYillarSonSat), 1, False)[/FONT]
[FONT=Courier New]MY_Sayisi = Benzersiz_Kayıtlar(shT.Range("B2:B" & TablomYillarSonSat), 1, False)[/FONT]
[FONT=Courier New]
Eğer TablomYillarSonSat 2 den büyük ise sorun yok, ancak TablomYillarSonSat = 2 ise yani, a2:a2 ye başvuru yaptığımızda yani elimizde tek kayıt varsa hata gönderiyor tek kayıtta sorun çıkartmayacak şekilde revizyon mümkün müdür?
Saygılarımla
 
Yani Aralik.Count = 1 ise değer sayısı olarak 1,

BY_Sayisi = Benzersiz_Kayıtlar(shT.Range("A2:A" & TablomYillarSonSat), 1, False)

sounucunu 1,

.Cells(syc_ii, "H").Value = Benzersiz_Kayıtlar(shT.Range("A2:A" & TablomYillarSonSat), syc_i)

sounucunu A2.value (Aralığın ilk ve son yani tek hücresi) olarak çevirsin.


 
De&#287;erli hocalar&#305;m biraz geli&#351;tirmeye &#231;al&#305;&#351;t&#305;m ama beceremedim, yeni eklenen sat&#305;rlar k&#305;rm&#305;z&#305; ile g&#246;sterilmi&#351;tir.


Kod: 
[FONT=Courier New]'Option Explicit[/FONT]
[FONT=Courier New]Function Benzersiz_Kay&#305;tlar(Aralik As Range, Sira As Integer, _[/FONT]
[FONT=Courier New]                   Optional ByVal Kay&#305;tlar As Boolean = True)[/FONT]
[FONT=Courier New]'Sn. Ferhat Pazar&#231;evirdi ve Sn. Veysel Emrenin Bilgilerinden derlenmi&#351;tir.[/FONT]
[FONT=Courier New]'Yazar: HSayar-Excel.web.tr[/FONT]
[FONT=Courier New]'Elemanlar&#305; h&#252;creye yazmak i&#231;in[/FONT]
[FONT=Courier New]   'VBA   da    : Benzersiz_Kayit(Aralik, i) &#351;eklinde kullanmal&#305;s&#305;n&#305;z. S&#305;rano 1 den ba&#351;lar.[/FONT]
[FONT=Courier New]   'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;SATIR()-1) &#351;eklinde kullanabilirsiniz.[/FONT]
[FONT=Courier New]''Eleman say&#305;s&#305;n&#305; &#246;&#287;renmek i&#231;in[/FONT]
[FONT=Courier New]   'VBA   da    : Benzersiz_Kayit(Aralik, 1, False) &#351;eklinde kullanmal&#305;s&#305;n&#305;z. S&#305;ra no olarak 1 kullan&#305;n[/FONT]
[FONT=Courier New]   'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;1;0) &#351;eklinde kullanbilirsiniz.[/FONT]
[FONT=Courier New]Dim y&, z&[/FONT]
[FONT=Courier New]Dim arrVeri(), colVeri, Ara         As Variant[/FONT]
[FONT=Courier New]Dim col                             As New Collection[/FONT]
[FONT=Courier New][COLOR=red][B]If Aralik.Count = 1 Then GoTo TekHucre      'test[/B][/COLOR][/FONT]
[FONT=Courier New]'Bir H&#252;cre Aral&#305;&#287;&#305;n&#305; Diziye Al====================================================================='\\[/FONT]
[FONT=Courier New]arrVeri = Aralik.Value                                                                              'II[/FONT]
[FONT=Courier New]'__________________________________________________________________________________________________'//[/FONT]
[FONT=Courier New]'ArrVerideki Benzersiz Kay&#305;tlar&#305; Koleksiyona Al===================================================='\\[/FONT]
[FONT=Courier New]On Error Resume Next                                            'De&#287;er koleksiyona al&#305;nm&#305;&#351;sa di&#287;erine ge&#231;[/FONT]
[FONT=Courier New]For Each colVeri In arrVeri                                     'Dizideki Benzersizleri[/FONT]
[FONT=Courier New]   If colVeri <> "" Then col.Add colVeri, (Format(colVeri, "@"))[/FONT]
[FONT=Courier New]Next                                                            'Di&#287;er elamana ge&#231;[/FONT]
[FONT=Courier New]On Error GoTo 0                                                 'Hata olursa s&#246;yle[/FONT]
[FONT=Courier New]'__________________________________________________________________________________________________'//[/FONT]
[FONT=Courier New]'ArrVeriyi yeniden olu&#351;tur.========================================================================'\\[/FONT]
[FONT=Courier New]ReDim arrVeri(1 To col.Count)                                                                      'II[/FONT]
[FONT=Courier New]For y = 1 To col.Count:         arrVeri(y) = UCaseTr(col(y)):    Next y                            'II[/FONT]
[FONT=Courier New]Set col = Nothing:              y = 0                                                              'II[/FONT]
[FONT=Courier New]'__________________________________________________________________________________________________'//[/FONT]
[FONT=Courier New]'S&#305;rala (0 dan Z'ye================================================================================'\\[/FONT]
[FONT=Courier New]For y = 1 To UBound(arrVeri) - 1                                                                   'II[/FONT]
[FONT=Courier New]   For z = y + 1 To UBound(arrVeri)                                                               'II[/FONT]
[FONT=Courier New]       If StrComp(arrVeri(y), arrVeri(z), vbTextCompare) = 1 Then                                 'II[/FONT]
[FONT=Courier New]           Ara = arrVeri(y)                                                                       'II[/FONT]
[FONT=Courier New]           arrVeri(y) = arrVeri(z)                                                                'II[/FONT]
[FONT=Courier New]           arrVeri(z) = Ara                                                                       'II[/FONT]
[FONT=Courier New]       End If                                                                                     'II[/FONT]
[FONT=Courier New]   Next                                                                                           'II[/FONT]
[FONT=Courier New]Next                                                                                               'II[/FONT]
[FONT=Courier New]Set Ara = Nothing:              y = 0:                           z = 0                             'II[/FONT]
[FONT=Courier New]'__________________________________________________________________________________________________'//[/FONT]
[FONT=Courier New]'Sonucu H&#252;creye veya de&#287;i&#351;kene ver '==============================================================='\\[/FONT]
[FONT=Courier New]If Kay&#305;tlar = True Then                                                                            'II[/FONT]
[FONT=Courier New]   If Sira > UBound(arrVeri) Then                                                                 'II[/FONT]
[FONT=Courier New]       Benzersiz_Kay&#305;tlar = ""                                                                    'II[/FONT]
[FONT=Courier New]   Else                                                                                           'II[/FONT]
[FONT=Courier New]       Benzersiz_Kay&#305;tlar = arrVeri(Sira)                                                         'II[/FONT]
[FONT=Courier New]   End If                                                                                         'II[/FONT]
[FONT=Courier New]Else                                                                                               'II[/FONT]
[FONT=Courier New]   Benzersiz_Kay&#305;tlar = UBound(arrVeri)                                                           'II[/FONT]
[FONT=Courier New]End If                                                                                             'II[/FONT]
[FONT=Courier New]'MsgBox "&#304;&#351;leminiz Bitti"""[/FONT]
[FONT=Courier New][COLOR=red][B]GoTo Son[/B][/COLOR][/FONT]
[FONT=Courier New][COLOR=red][B]TekHucre:[/B][/COLOR][/FONT]
[FONT=Courier New][COLOR=red][B]'MsgBox "Tek h&#252;cre Sorunu"[/B][/COLOR][/FONT]
[FONT=Courier New][COLOR=red][B]   With Aralik[/B][/COLOR][/FONT]
[FONT=Courier New][COLOR=red][B]        AraHucIlk = Cells(.Row, .Column).Value[/B][/COLOR][/FONT]
[FONT=Courier New][COLOR=red][B]        'AraHucSon = Cells(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1).address[/B][/COLOR][/FONT]
[FONT=Courier New][COLOR=red][B]   End With[/B][/COLOR][/FONT]
[FONT=Courier New][COLOR=red][B]   If Kay&#305;tlar = True Then                                                                            'II[/B][/COLOR][/FONT]
[FONT=Courier New][COLOR=red][B]       Benzersiz_Kay&#305;tlar = AraHucIlk                                                         'II[/B][/COLOR][/FONT]
[FONT=Courier New][COLOR=red][B]   Else                                                                                               'II[/B][/COLOR][/FONT]
[FONT=Courier New][COLOR=red][B]       Benzersiz_Kay&#305;tlar = 1                                                           'II[/B][/COLOR][/FONT]
[FONT=Courier New][COLOR=red][B]   End If[/B][/COLOR][/FONT]
[FONT=Courier New]'__________________________________________________________________________________________________'//[/FONT]
[FONT=Courier New][B][COLOR=red]Son:[/COLOR][/B][/FONT]
[FONT=Courier New]Set Aralik = Nothing[/FONT]
[FONT=Courier New]End Function[/FONT]

Yard&#305;mlar&#305;n&#305;n&#305;z&#305; esirgemesezseniz sevinirim.
 
Aralık birtek hücreye müracaat etsede sorun çıkartmıyor.
Ferhat hocama tekrar yardımları için teşekkür ederim.

Kod: 
'Option Explicit
Function Benzersiz_Kayıtlar(Aralik As Range, Sira As Integer, _
                    Optional ByVal Kayıtlar As Boolean = True)
'Sn. Ferhat Pazarçevirdi ve Sn. Veysel Emrenin Bilgilerinden derlenmiştir.
'Yazar: HSayar-Excel.web.tr
'Elemanları hücreye yazmak için
    'VBA   da    : Benzersiz_Kayit(Aralik, i) şeklinde kullanmalısınız. Sırano 1 den başlar.
    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;SATIR()-1) şeklinde kullanabilirsiniz.
''Eleman sayısını öğrenmek için
    'VBA   da    : Benzersiz_Kayit(Aralik, 1, False) şeklinde kullanmalısınız. Sıra no olarak 1 kullanın
    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;1;0) şeklinde kullanbilirsiniz.
Dim y&, z&
Dim arrVeri(), colVeri, Ara         As Variant
Dim col                             As New Collection
If Aralik.Count = 1 Then GoTo TekHucre      'test
'Bir Hücre Aralığını Diziye Al====================================================================='\\
arrVeri = Aralik.Value                                                                              'II
'__________________________________________________________________________________________________'//
'ArrVerideki Benzersiz Kayıtları Koleksiyona Al===================================================='\\
On Error Resume Next                                            'Değer koleksiyona alınmışsa diğerine geç
For Each colVeri In arrVeri                                     'Dizideki Benzersizleri
    If colVeri <> "" Then col.Add colVeri, (Format(colVeri, "@"))
Next                                                            'Diğer elamana geç
On Error GoTo 0                                                 'Hata olursa söyle
'__________________________________________________________________________________________________'//
'ArrVeriyi yeniden oluştur.========================================================================'\\
ReDim arrVeri(1 To col.Count)                                                                      'II
For y = 1 To col.Count:         arrVeri(y) = UCaseTr(col(y)):    Next y                            'II
Set col = Nothing:              y = 0                                                              'II
'__________________________________________________________________________________________________'//
'Sırala (0 dan Z'ye================================================================================'\\
For y = 1 To UBound(arrVeri) - 1                                                                   'II
    For z = y + 1 To UBound(arrVeri)                                                               'II
        If StrComp(arrVeri(y), arrVeri(z), vbTextCompare) = 1 Then                                 'II
            Ara = arrVeri(y)                                                                       'II
            arrVeri(y) = arrVeri(z)                                                                'II
            arrVeri(z) = Ara                                                                       'II
        End If                                                                                     'II
    Next                                                                                           'II
Next                                                                                               'II
Set Ara = Nothing:              y = 0:                           z = 0                             'II
'__________________________________________________________________________________________________'//
'Sonucu Hücreye veya değişkene ver '==============================================================='\\
If Kayıtlar = True Then                                                                            'II
    If Sira > UBound(arrVeri) Then                                                                 'II
        Benzersiz_Kayıtlar = ""                                                                    'II
    Else                                                                                           'II
        Benzersiz_Kayıtlar = arrVeri(Sira)                                                         'II
    End If                                                                                         'II
Else                                                                                               'II
    Benzersiz_Kayıtlar = UBound(arrVeri)                                                           'II
End If                                                                                             'II
'MsgBox "İşleminiz Bitti"""
GoTo Son
TekHucre:
'MsgBox "Tek hücre Sorunu"
    With Aralik
         AraHucIlk = .Worksheet.Cells(.Row, .Column).Value
         'AraHucSon = Cells(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1).address
    End With
    If Kayıtlar = True Then                                                                            'II
        Benzersiz_Kayıtlar = AraHucIlk                                                         'II
    Else                                                                                               'II
        Benzersiz_Kayıtlar = 1                                                           'II
    End If
'__________________________________________________________________________________________________'//
Son:
Set Aralik = Nothing
End Function
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst