Benzersiz Kayıtları Listboxa eklemek

[canercan02]

Arkadaşlar merhaba
Ekteki dosyada sayfa 1 içerisinde İller ve gezi tarihleri mevcut.
Yapmak istediğim şey her ili benzersiz olarak sayfa 2 ye kaydettiğim gibi formdaki listboxa eklemek (Önemli olan sayfa 2 değil listboxa eklenmesi)

Yani sayfa1 içerisindeki listedeki illeri formdaki listbox1 e aktarıp aynı satırda gezi sayısını karşısına yazdırmak istiyorum. yardımlarınız için teşekkürler

 

[canercan02]

sorunun son aşamasına geldim.
Listbox1 içerisine Süzerek illeri ve illere yapılan gezileri getirdim. fakat il üzerine tıklayınca listbox2 de seçili ile yapılan gezi tarihlerinin gelmesini istiyorum.
Çözüm konusunda hiç bir fikrim yok. yardımcı olursanız sevinirim.

 

[Orion1]

dosyanız ektedir.

Private Sub ListBox1_Click()
Dim k As Range, sat As Long
If ListBox1.ListCount < 1 Then Exit Sub
sat = Sheets("Sayfa1").Cells(Rows.Count, "B") _
.End(xlUp).Row
ListBox2.Clear
Set k = Sheets("Sayfa1").Range("B1:B" & sat).Find(ListBox1.Column(0), , xlValues, xlWhole)
If Not k Is Nothing Then
    adr = k.Address
    Do
        ListBox2.AddItem Format(k.Offset(0, 1).Value, "dd.mm.yyyy")
        Set k = Sheets("Sayfa1").Range("B1:B" & sat).FindNext(k)
    Loop While Not k Is Nothing And k.Address <> adr
End If
End Sub

 

[canercan02]

sayın Orion hocam ilginiz için çok teşekkür ederim.
yaptığınız şekilde listebox2 ye veriler tam olarak gelmiyor. örneğin aydın ili seçildiğinde 5 ayrı tarihin gelmesi gerekiyor.
şu şekilde kendimce bir çözüm yolu buldum. şu anda sorunumu çözüyor.
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa3")
s2.Select
Range("A1:c50").Select
Selection.ClearContents
s1.Select
Range("A1:C1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=2, Criteria1:=ListBox1.Column(0)
Selection.CurrentRegion.Select
Selection.Copy

s2.Select
Range("A1").Select
ActiveSheet.Paste
s1.Select
Application.CutCopyMode = False
ActiveSheet.ShowAllData
Sheets("Sayfa3").Select
sat3 = s2.[a500].End(3).Row

ListBox2.RowSource = "sayfa3!c2:c" & sat3
End Sub

 

[Orion1]

sayın Orion hocam ilginiz için çok teşekkür ederim.
yaptığınız şekilde listebox2 ye veriler tam olarak gelmiyor. örneğin aydın ili seçildiğinde 5 ayrı tarihin gelmesi gerekiyor.

ben soruyu yanlış anlamışım.
3 nolu mesajda dosyayı tekrar güncelledim.
Oradan ekli dosyayı indirebilirisiniz.

 

[canercan02]

tamamdır hocam elinize sağlık

 

[canercan02]

Benzersiz kayıtları süz komutu ile değil de farklı bir yöntemle yapmak için arama yaptığımda Orion hocamızın aşağıdaki kodları ile karşılaştım.

Sub benzersiz()
Dim sat As Long
Application.ScreenUpdating = False
Sheets("Sayfa2").Range("A1:A65536").ClearContents
sat = 1
For Each hucre In Range("b1:b700")
If WorksheetFunction.CountIf(Range("b1:b700"), hucre.Value) = 1 Then
Sheets("Sayfa2").Cells(sat, "A").Value = hucre.Value
sat = sat + 1
End If
Next
Application.ScreenUpdating = True
MsgBox "Benzersizler Sayfa2'ye Aktarıldı..!!", vbOKOnly + vbInformation, Application.UserName
End Sub


fakat burada sadece 1 defa kayıtları alıyor. Bütün kayıtları 1 defa alacak şekilde nasıl değiştirebiliriz. yani 3 defa tekrar edenleri de 1 defa yazdırması için kodu nasıl düzenleyebiliriz.

 

[Orion1]

Buyurun.

Sub benzersiz()
Dim sat As Long, i As Long, sat2 As Long
Application.ScreenUpdating = False
Sheets("Sayfa2").Range("A1:A65536").ClearContents
sat = 1
For i = 1 To 700
If WorksheetFunction.CountIf(Range("b1:b" & i), Cells(i, "B").Value) = 1 Then
Sheets("Sayfa2").Cells(sat, "A").Value = Cells(i, "B").Value
sat = sat + 1
End If
Next
Application.ScreenUpdating = True
MsgBox "Benzersizler Sayfa2'ye Aktarıldı..!!", vbOKOnly + vbInformation, Application.UserName
End Sub

 

[sbayyigit]

Allah Razı olsun hocam ben de faydalandım.

 

[baydeniro]

Sayın Orion1, çok teşekkürler.

 

[canercan02]

çok teşekkürler hocam işime çok yaradı.

 

[canercan02]

bu sorunuma da çözüm bulabilirseniz çok sevinirim.

örnek olarak
zayif = 50 'den küçük

gecer = 50-85 arası

iyi = 85-100 arası

aşağıdaki vba kodu ile aralıktaki zayıf, geçer ve iyilerin sayısını bulmak istiyorum.
ama bir türlü kodu oluşturamadım.

kucuk = Application.WorksheetFunction.CountIf(s1.Range(Cells(7, sor), Cells(26, sor)), zayif)
orta = Application.WorksheetFunction.CountIf(s1.Range(Cells(7, sor), Cells(26, sor)), gecer)
buyuk = Application.WorksheetFunction.CountIf(s1.Range(Cells(7, sor), Cells(26, sor)), iyi)

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki gibi deneyin.

Sub Say()
    MsgBox "Zayıf Sayısı ; " & WorksheetFunction.CountIf([A1:A500], "<50")
    MsgBox "Geçer Sayısı ; " & Evaluate("=SUMPRODUCT((A1:A500>=50)*(A1:A500<85))")
    MsgBox "İyi Sayısı ; " & Evaluate("=SUMPRODUCT((A1:A500>=85)*(A1:A500<=100))")
End Sub

 

[canercan02]

çok teşekkürler hocam. Sayenizde hallettim.

 

[xagox]

Merhabalar
Konuyu açana da Cevaplayan sn Oriona da teşekkürler.
Bende sayenizde faydalandım...