Bir diziyi Sıralamak Mümkünmüdür?

hsayar · 28 Şubat 2008

Sayın Ferhat Hocamın yapmış olduğu benzersiz kayıtları bulan diziyi biraz değiştirerek kendi ihtiyaçlarım doğrultusunda geliştirdim.

Fonksiyon bir aralıktaki benzersiz kayıtları diziye alıyor mesala

a1:a10 aralığındaki verilerimiz
Mustafa Iş., Ali KARAT…, Hüseyin KAP…, Hasan GEÇ……, Elif KO….., İsmet Yaş.. OKÇ……., Hasan KAP….., Hüseyin KAR………, Mehmet ÖZ…., Hasan GAÇ……,

ise diziye alındığındaki görüntü
Ali KARAT…, Elif KO….., Hasan GAÇ……, Hasan GEÇ……, Hasan KAP….., Hüseyin KAP…, Hüseyin KAR………, İsmet Yaş.. OKÇ……., Mehmet ÖZ…., Mustafa Iş.,

bu şekilde alfabetik sıralama yapılabilirmi

Kod:

Function Benzersiz_Kayit(Aralik As Range, Sira As Integer, _
                    Optional ByVal Kay&#305;tlar As Boolean = True)
'Elemanlar&#305; h&#252;creye yazmak i&#231;in
    'VBA   da    : Benzersiz_Kayit(Aralik, i + 1) &#351;eklinde kullanmal&#305;s&#305;n&#305;z. S&#305;rano 1 den ba&#351;lar.
    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;SATIR()-1) &#351;eklinde kullanabilirsiniz.
    'Dikkat Aral&#305;&#287;&#305;n son h&#252;cresini diekkate alm&#305;yor Sayfa3!$C$3:$C$23 yaz&#305;m&#305; asl&#305;nda Sayfa3!$C$3:$C$22 ye kadar ?????
 
 
''Eleman say&#305;s&#305;n&#305; &#246;&#287;renmek i&#231;in
    '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
    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;1;0) &#351;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&#305;tlar = True Then
    If Sira > UBound(arrVeri) Then
        'Exit Sub
        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, "&#305;", "I"), "i", "&#304;"))
End Function

hsayar · 29 Şubat 2008

GÜnaydın.
Güncel yardım edebilirseniz sevinirim.

hsayar · 29 Şubat 2008

iyi akşamlar.
Güncel yardım edebilirseniz sevinirim.

hsayar · 1 Mart 2008

GÜnaydın.
Güncel yardım edebilirseniz sevinirim.

hsayar · 1 Mart 2008

GÜnaydın.
Güncel yardım edebilirseniz sevinirim.

hsayar · 2 Mart 2008

hsayar' Alıntı:
Sayın Ferhat Hocamın yapmış olduğu benzersiz kayıtları bulan diziyi biraz değiştirerek kendi ihtiyaçlarım doğrultusunda geliştirdim.

Fonksiyon bir aralıktaki benzersiz kayıtları diziye alıyor mesala

a1:a10 aralığındaki verilerimiz
Mustafa Iş., Ali KARAT…, Hüseyin KAP…, Hasan GEÇ……, Elif KO….., İsmet Yaş.. OKÇ……., Hasan KAP….., Hüseyin KAR………, Mehmet ÖZ…., Hasan GAÇ……,

ise diziye alındığındaki görüntü
Ali KARAT…, Elif KO….., Hasan GAÇ……, Hasan GEÇ……, Hasan KAP….., Hüseyin KAP…, Hüseyin KAR………, İsmet Yaş.. OKÇ……., Mehmet ÖZ…., Mustafa Iş.,

bu şekilde alfabetik sıralama yapılabilirmi

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. 'Dikkat Aralığın son hücresini diekkate almıyor Sayfa3!$C$3:$C$23 yazımı aslında Sayfa3!$C$3:$C$22 ye kadar ????? ''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 > UBound(arrVeri) Then 'Exit Sub 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

Güncel yardım edebilirseniz sevinirim.

hsayar · 3 Mart 2008

Güncel yardım edebilirseniz sevinirim.

Ferhat Pazarçevirdi · 3 Mart 2008

http://www.excel.web.tr/showthread.php?t=46260

Linkini inceleyiniz. Bu linkte, Listbox'ta sıralama anlatılmıştır. Diziler için de aynı mantık geçerlidir.

hsayar · 3 Mart 2008

Hocam dediğiniz yöntemi denedim ama değer hatası veriyor hatam nerede acaba

Kod:

Function Benzersiz_Kayit(Aralik As Range, Sira As Integer, _
                    Optional ByVal Kay&#305;tlar As Boolean = True)
'Elemanlar&#305; h&#252;creye yazmak i&#231;in
    'VBA   da    : Benzersiz_Kayit(Aralik, i + 1) &#351;eklinde kullanmal&#305;s&#305;n&#305;z. S&#305;rano 1 den ba&#351;lar.
    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;SATIR()-1) &#351;eklinde kullanabilirsiniz.
    'Dikkat Aral&#305;&#287;&#305;n son h&#252;cresini diekkate alm&#305;yor Sayfa3!$C$3:$C$23 yaz&#305;m&#305; asl&#305;nda Sayfa3!$C$3:$C$22 ye kadar ?????
 
 
''Eleman say&#305;s&#305;n&#305; &#246;&#287;renmek i&#231;in
    '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
    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;1;0) &#351;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
'======================
 For i = 0 To UBound(arrVeri) - 1
    For j = i + 1 To UBound(arrVeri) - 1
        If arrVeri(i) > arrVeri(j) Then
           x = arrVeri(i)
           arrVeri(i) = arrVeri(j)
           arrVeri(j) = x
        End If
    Next j
Next i
'======================
If Kay&#305;tlar = True Then
    If Sira > UBound(arrVeri) Then
        'Exit Sub
        Benzersiz_Kayit = ""
    Else
        Benzersiz_Kayit = arrVeri(Sira - 1)
    End If
Else
    Benzersiz_Kayit = UBound(arrVeri)
End If
End Function

Ferhat Pazarçevirdi · 4 Mart 2008

Long olarak tanımladığınız bir değişkene; String türünde bir değer yüklemeye çalışmışsınız (x değişkeni)

Kodunuzun belirtilen kısmını değiştirin.

Kod:

Dim [COLOR=red]eleman[/COLOR] as string
..........
..........
For i = 0 To UBound(arrVeri) - 1
    For j = i + 1 To UBound(arrVeri) - 1
        If arrVeri(i) > arrVeri(j) Then
           [COLOR=red]eleman[/COLOR] = arrVeri(i)
           arrVeri(i) = arrVeri(j)
           arrVeri(j) = [COLOR=red]eleman
[/COLOR]        End If
    Next j
Next i
.......
.......

hsayar · 4 Mart 2008

teşekkürler hocam.

hsayar · 4 Mart 2008

Hocam tekrar teşekkür ederim yalnız bu işte bir terslik var Ç,Ş,Ö,İ gibi Türk Alfabesinde kullanılan sesler sıralamada Y den Sonra Z Den önce yer alıyor.. bir şey yapılabilirmi?

Gerçi benim aklıma Diziyi IV1 e atıp sıralamak ve diziye tekrar almak geldi ama
Range("H1").Resize(UBound(arrVeri) + 1).Value = arrVeri ' veriyi hücreler yaz. (Not: H görebilmek için kulladım)
satırında takıldım. eğer geçersem Normal excel sıralaması yaptırıp
ArrVeri = Range("H1:H" & [H65536].End(3).Row).Value 'Veri aralığını geri al
şeklinde düşünüyorum ama olmadı

veyselemre · 4 Mart 2008

Örneği kendinize uyarlayın.

hsayar · 4 Mart 2008

teşekkür ederim

hsayar · 5 Mart 2008

SN VeyselEmre nin kodlarında metin fromatlı olmayan hücrelerde hata veriyordu
aşmak için kendisini kodlarında küçük bir yeniden düzenleme yaptım.
Ancak kırmızı satırları açıklyabilirseniz sevinirim.
Ayrıca
For Each B In arrVeri
Satırnda b nin veri tipi nedir?

Kod:

Sub deneme()
On Error Resume Next


Dim arrVeri():  arrVeri = Range("a1:B" & [a65536].End(3).Row).Value
[C:C].ClearContents

Dim col As New Collection
For Each [COLOR=Red]B[/COLOR] In arrVeri
    col.Add B, Format(B, "@")
Next

say = col.Count
ReDim arrVeri(1 To say)
For y = 1 To say
    arrVeri(y) = col(y)
Next y
Set col = Nothing

'S&#305;rala=====================================================================\\
For y = 1 To say - 1                                                       'II
    For z = y + 1 To say                                                   'II
       [COLOR=Red] If StrComp(arrVeri(y), arrVeri(z), vbTextCompare) [/COLOR]= 1 Then         'II
            Ara = arrVeri(y)                                               'II
            arrVeri(y) = arrVeri(z)                                        'II
            arrVeri(z) = Ara                                               'II
        End If                                                             'II
    Next                                                                   'II
Next                                                                       'II
'__________________________________________________________________________'//

Range("C1").Resize(UBound(arrVeri)).Value = [COLOR=Red]WorksheetFunction.Transpose(arrVeri)
[/COLOR] 
End Sub

hsayar · 5 Mart 2008

....................... Sorun çözüldü.18. mesajı bakabilirsiniz.

hsayar · 6 Mart 2008

Çalışmamın Nihai Hali Aşğıdaki linktedir.
http://www.excel.web.tr/showthread.php?p=253067#post253067

hsayar · 6 Mart 2008

Sn. Ferhat Pazarçevirdi ve Sn. Veysel Emrenin Bilgilerinden derlenmiştir.
kendilerine tekrar teşekkür ederim.

Başka Bir kitaptaki benzersiz kayıtları bir sayfaya getirmek ve osütunda sıralı olarak Göstermek için aşağıdaki fonksiyonu kullanabilirsiniz.
Benzersiz kayıtları satır olarak getimekte mümkün.

Kod:

=Benzersiz_Kay&#305;tlar([COLOR=Red]Aral&#305;k[/COLOR];[COLOR=DarkGreen]S&#305;raNo[/COLOR])

Kod:

=Benzersiz_Kay&#305;tlar([COLOR=Red][Kitap2]Sayfa1!$G$4:$K$10[/COLOR];[COLOR=DarkGreen]B22[/COLOR])

Kod:

Option Explicit
Function Benzersiz_Kay&#305;tlar(Aralik As Range, Sira As Integer, _
                    Optional ByVal Kay&#305;tlar As Boolean = True)
'Sn. Ferhat Pazar&#231;evirdi ve Sn. Veysel Emrenin Bilgilerinden derlenmi&#351;tir.
'Yazar: HSayar-Excel.web.tr
'Elemanlar&#305; h&#252;creye yazmak i&#231;in
    'VBA   da    : Benzersiz_Kayit(Aralik, i) &#351;eklinde kullanmal&#305;s&#305;n&#305;z. S&#305;rano 1 den ba&#351;lar.
    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;SATIR()-1) &#351;eklinde kullanabilirsiniz.
''Eleman say&#305;s&#305;n&#305; &#246;&#287;renmek i&#231;in
    '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
    'Excel de    : =Benzersiz_Kayit(Sayfa3!$C$3:$C$23;1;0) &#351;eklinde kullanbilirsiniz.
Dim y&, z&
Dim arrVeri(), colVeri, Ara         As Variant
Dim col                             As New Collection


'Bir H&#252;cre Aral&#305;&#287;&#305;n&#305; Diziye Al====================================================================='\\
arrVeri = Aralik.Value                                                                              'II
'__________________________________________________________________________________________________'//


'ArrVerideki Benzersiz Kay&#305;tlar&#305; Koleksiyona Al===================================================='\\
On Error Resume Next                                            'De&#287;er koleksiyona al&#305;nm&#305;&#351;sa di&#287;erine ge&#231;
For Each colVeri In arrVeri                                     'Dizideki Benzersizleri
    If colVeri <> "" Then col.Add colVeri, (Format(colVeri, "@"))
Next                                                            'Di&#287;er elamana ge&#231;
On Error GoTo 0                                                 'Hata olursa s&#246;yle
'__________________________________________________________________________________________________'//

'ArrVeriyi yeniden olu&#351;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
'__________________________________________________________________________________________________'//

[COLOR=Red] 'S&#305;rala (0 dan Z'ye================================================================================'\\[/COLOR]
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&#252;creye veya de&#287;i&#351;kene ver '==============================================================='\\
If Kay&#305;tlar = True Then                                                                            'II
    If Sira > UBound(arrVeri) Then                                                                 'II
        Benzersiz_Kay&#305;tlar = ""                                                                    'II
    Else                                                                                           'II
        Benzersiz_Kay&#305;tlar = arrVeri(Sira)                                                         'II
    End If                                                                                         'II
Else                                                                                               'II
    Benzersiz_Kay&#305;tlar = UBound(arrVeri)                                                           'II
End If                                                                                             'II
'__________________________________________________________________________________________________'//
End Function

Sn veysel hocam Sıralama Kısmını 0,1,2...A,B,C,Ç..........V,Y,Z şeklinde hallettik.
peki tam tersiini isteseydik (z,y,...........c,b,a,9,8,7,......0 ) gibi ne yapmalıydık.

Ferhat Pazarçevirdi · 6 Mart 2008

Strcomp değerini 2'ye eşitleyerek, koşulu revize ediniz.

hsayar · 7 Mart 2008

teşekkür ederim hocam

Bir diziyi Sıralamak Mümkünmüdür?

hsayar

hsayar

hsayar

hsayar

hsayar

hsayar

hsayar

Ferhat Pazarçevirdi

Özel Üye

hsayar

Ferhat Pazarçevirdi

Özel Üye

hsayar

hsayar

veyselemre

Özel Üye

hsayar

hsayar

hsayar

hsayar

hsayar

Ferhat Pazarçevirdi

Özel Üye

hsayar