-
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
- Konbuyu başlatan hsayar
- Başlangıç tarihi
Ferhat Pazarçevirdi
Özel Üye
- Katılım
- 15 Haziran 2006
- Mesajlar
- 3,704
- Excel Vers. ve Dili
- Excel 2003, 2007, 2010 (TR)
- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
-
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
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ı
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ı
- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
-
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
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
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- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
-
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
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.
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:
Ferhat Pazarçevirdi
Özel Üye
- Katılım
- 15 Haziran 2006
- Mesajlar
- 3,704
- Excel Vers. ve Dili
- Excel 2003, 2007, 2010 (TR)
Sorunuzun son şekli nedir ?
- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
-
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
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.
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.
- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
-
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Değer Hatası dönmesin diye koydupum kontreolde mantık hatası yapmışım hocam özür dilerim.
[/LEFT]
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
Son düzenleme:
- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
-
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
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 FunctionDeğ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
- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
-
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
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.
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.
- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
-
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Değerli hocalarım biraz geliştirmeye çalıştım ama beceremedim, yeni eklenen satırlar kırmızı ile gösterilmiştir.
Yardımlarınınızı esirgemesezseniz sevinirim.
Kod:
[FONT=Courier New]'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][COLOR=red][B]If Aralik.Count = 1 Then GoTo TekHucre 'test[/B][/COLOR][/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]'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]'MsgBox "İş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ü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ıtlar = True Then 'II[/B][/COLOR][/FONT]
[FONT=Courier New][COLOR=red][B] Benzersiz_Kayı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ı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]- Katılım
- 2 Mart 2005
- Mesajlar
- 2,960
- Excel Vers. ve Dili
-
ev: Ofis 2007- Win Xp
iş: Ofis 2010- Win Vista
Aralık birtek hücreye müracaat etsede sorun çıkartmıyor.
Ferhat hocama tekrar yardımları için teşekkür ederim.
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