Benzersiz Listeleme

[orkuncan5]

Formda mükerrer uygulamaları var ama kendime uyarlayamadım....Çeşitli sayıların olduğu sayfada aynı sayılardan çeşitli sayıda var.Ben bunları mükerrer olanlardan sadece birtane mükerrer olmayanlarında hepsini userformdaki listviewde küçükten büyüğe listelemek istiyorum.Yardımlarınızı bekliyorum.

 

[Orion1]

İnitialize olayına yazınız.

Option Base 1
Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()
Dim hcr As Range, z As Object, list(), i As Long, j As Long
ListView1.View = lvwReport
ListView1.FullRowSelect = True
ListView1.ColumnHeaders.Add , , "BENZERSİZER", 180
Set z = CreateObject("Scripting.Dictionary")
ReDim list(1 To 1, 1 To 65536)
For Each hcr In Range("F1:P4")
    If hcr.Value <> "" Then
        If IsNumeric(hcr.Value) Then
            If Not z.exists(hcr.Value) Then
                a = a + 1
                list(1, a) = hcr.Value
                z.Add hcr.Value, Nothing
            End If
        End If
    End If
Next
ReDim Preserve list(1 To 1, 1 To a)

For i = 1 To a - 1
    For j = i + 1 To a
        If list(1, i) > list(1, j) Then
            x = list(1, j)
            list(1, j) = list(1, i)
            list(1, i) = x
        End If
    Next j
Next
For i = 1 To a
    ListView1.ListItems.Add , , list(1, i)
Next

End Sub

 

[orkuncan5]

Evren Bey teşekkür ederim.Fakat sıralamada bir sorun çıktı.Çalışma sayfasındaki rakamların arasındaki hücrelerde boş hücre veya kelime olunca sıralama bozuluyor.Bu konuda yardımcı olabilirmisiniz.

 

[Orion1]

Evren Bey teşekkür ederim.Fakat sıralamada bir sorun çıktı.Çalışma sayfasındaki rakamların arasındaki hücrelerde boş hücre veya kelime olunca sıralama bozuluyor.Bu konuda yardımcı olabilirmisiniz.

Boş hücre yada kelime varsa onları değerlendirmesinmi.
Yani onlar devre dışımı kalsın.

 

[orkuncan5]

Boş hücreyi ve kelimeyi değerlendirmesin . Rakamları küçükten büyüğe sıralasın

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Private Sub UserForm_Initialize()
    Dim WF As WorksheetFunction, Biçim As String
    Dim Hücre As Range, SD As Object, X As Long
 
    Application.ScreenUpdating = False
 
    Set WF = WorksheetFunction
    Set SD = CreateObject("Scripting.Dictionary")
 
    With ListView1
        .View = lvwReport
        .FullRowSelect = True
        .Gridlines = True
        .LabelEdit = lvwManual
        .ListItems.Clear
        .ColumnHeaders.Clear
 
        With .ColumnHeaders
            .Add , , "BENZERSİZLER", ListView1.Width - 16
            .Add , , "SIRALAMA", 0
        End With
        
        Biçim = WF.Rept(0, 15) & "." & WF.Rept(0, 30)
 
        For Each Hücre In Range("F1:P1000")
            If Not IsEmpty(Hücre.Value) And IsNumeric(Hücre.Value) Then
                If Not SD.Exists(Hücre.Value) Then
                     SD.Add Hücre.Value, Nothing
                     X = X + 1
                    .ListItems.Add , , Hücre.Value
                    .ListItems(X).ListSubItems.Add , , Format(Hücre.Text, Biçim)
                End If
            End If
        Next
 
        .Sorted = True
        .SortKey = 1
        .SortOrder = lvwAscending
        .ColumnHeaders.Remove (2)
        .Refresh
    End With
 
    Set WF = Nothing
    Set SD = Nothing
 
    Application.ScreenUpdating = True
End Sub

 

[Orion1]

Boş hücreyi ve kelimeyi değerlendirmesin . Rakamları küçükten büyüğe sıralasın

Merhaba.
Kodları düzenledim.
Örnek dosyyıyıda verdim.
2 numaralı mesajdan indirebilirsiniz.

 

[makan]

Merhaba.
Kodları düzenledim.
Örnek dosyyıyıda verdim.
2 numaralı mesajdan indirebilirsiniz.

Evren hocam, benim pc.de resimdeki gibi bir hata çıktı. Neden olabilir.

 

[halit3]

Bir alternatifte ben ekliyorum.

Option Explicit
Private Sub UserForm_Initialize()
Dim x, j, s, i
Set j = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
ListView1.View = lvwReport
ListView1.FullRowSelect = True
ListView1.Gridlines = True
ListView1.LabelEdit = lvwManual
ListView1.ColumnHeaders.Add , , "BENZERSİZLER", 200
ListView1.ColumnHeaders.Add , , "silinecek", 0
For Each x In [f1:p15]
If x.Value <> "" Then
If IsNumeric(x.Value) = True Then
If Not j.Exists(x.Value) Then
j.Add x.Value, Nothing
ListView1.ListItems.Add , , Format(x.Value, "000000000000000")
s = s + 1
ListView1.ListItems(s).ListSubItems.Add , , x.Value
End If
End If
End If
Next x
ListView1.Sorted = True
ListView1.SortKey = 1
ListView1.SortOrder = lvwAscending
ListView1.Sorted = False
For i = 1 To ListView1.ListItems.Count
ListView1.ListItems(i).Text = ListView1.ListItems(i).ListSubItems(1).Text
ListView1.ListItems(i).ListSubItems.Remove 1
Next
ListView1.ColumnHeaders.Remove 2
ListView1.Refresh
Application.ScreenUpdating = True
End Sub

Option Explicit
Private Sub UserForm_Initialize()
Dim x, j, s, i
Set j = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
ListView1.View = lvwReport
ListView1.FullRowSelect = True
ListView1.Gridlines = True
ListView1.LabelEdit = lvwManual
ListView1.ColumnHeaders.Add , , "BENZERSİZLER", 200

For Each x In [f1:p15]
If x.Value <> "" Then
If IsNumeric(x.Value) = True Then
If Not j.exists(x.Value) Then
j.Add x.Value, Nothing
ListView1.ListItems.Add , , Format(x.Value, "000000000000000")
End If
End If
End If
Next x
ListView1.Sorted = True
ListView1.SortKey = 0
ListView1.SortOrder = lvwAscending
ListView1.Sorted = False
For i = 1 To ListView1.ListItems.Count
ListView1.ListItems(i).Text = _
Val(ListView1.ListItems(i).Text)
Next i

Application.ScreenUpdating = True
End Sub

 

[Orion1]

Evren hocam, benim pc.de resimdeki gibi bir hata çıktı. Neden olabilir.

Tamam'a basın.

 

[Orion1]

yanlış dosya eklemişim.
Şimdi düzellttim.
2 numaralı mesajdan indirebilirsiniz.

 

[adaglar]

excel olarak sudoku varmı

 

[orkuncan5]

Korhan Bey ,Evren Bey ve Halit Bey hepinize ayrı ayrı teşekkür ederim.Kodların hepside işime yaradı.

 

[Orion1]

hücrelerdenbazılaraına 1,10,1000 koyarak sıralamayı deneremisiniz?

 

[orkuncan5]

Evren Bey sizin verdiğiniz kodda dediğinizi yaptım normal sıraladı

 

[Orion1]

Evren Bey sizin verdiğiniz kodda dediğinizi yaptım normal sıraladı

İyi,problem yok.Diğerlerinide deneyin isterseniz.

 

[orkuncan5]

Diğerlerinde denedim sıralamayı yanlış yaptı.Sizin verdiğiniz kod doğru yaptı.Yalnız listviewdeki numaraları altalta sıralanacak biçimde yapabilirmiyiz.

 

[Orion1]

Diğerlerinde denedim sıralamayı yanlış yaptı.Sizin verdiğiniz kod doğru yaptı.Yalnız listviewdeki numaraları altalta sıralanacak biçimde yapabilirmiyiz.

Bunu anlamadım.
Zaten küçükten büyüğe sıralama yapıyor.

 

[orkuncan5]

Demek istediğim sıralama da sayılar yanyana değilde alt alta gelebilirmi

 

[Orion1]

Demek istediğim sıralama da sayılar yanyana değilde alt alta gelebilirmi

zaten alt alta