userform - listbox sorunu

[omurkorkmaz]

Örnek dosyada SONUÇ:1 ve SONUÇ:2 olmak üzere iki bölüm var.
formu açtığımız zaman ARAMA yapılacak seçenekler verilmiş durumda.
eğer aradığımız değer SONUÇ:1 de ise ListBox1 de varolan verilerin tamamını gösterecek
eğer aradığımız değer SONUÇ:2 de ise ListBox2 de aradığımız verilerin tamamını gösterecek




Ayrıca SONUÇ:1 ve SONUÇ:2 ana başlıklarının altındaki sütünlarda gönderdiğiniz dosyayı
anlayabilirsem 2 ya da 3 sütun daha çoğaltabilirim / çoğalabilir



Şunu belirteyim Bu Formu da bu sitede buldum kendime uyarlamaya çalıştım uğraştım ama en sonunda
yapamayacağımı anlayıp sizden yardım istedim

 

[Korhan Ayhan]

Merhaba,

Ekteki örnek dosyayı incelermisiniz.

Uygulanan kod;

Private Sub CommandButton1_Click()
    Dim S1 As Worksheet, Bul As Range, Adres As String
    Dim Adres1 As Range, Adres2 As Range, Satır As Long
    
    Set S1 = Sheets("Veri")
    
    ListBox1.Clear
    ListBox2.Clear
    ListBox1.IntegralHeight = False
    ListBox2.IntegralHeight = False
    
    If OptionButton1 = False And OptionButton2 = False And OptionButton3 = False And OptionButton4 = False Then
        MsgBox "Lütfen arama kriterinizi seçiniz !", vbCritical
        Exit Sub
    End If
    
    If TextBox1 = "" Then
        MsgBox "Lütfen aramak istediğiniz veriyi giriniz !", vbCritical
        TextBox1.SetFocus
        Exit Sub
    End If
    
    If OptionButton1 = True Then
        Set Adres1 = S1.Range("A:A")
        Set Adres2 = S1.Range("H:H")
    ElseIf OptionButton2 = True Then
        Set Adres1 = S1.Range("B:B")
        Set Adres2 = S1.Range("I:I")
    ElseIf OptionButton3 = True Then
        Set Adres1 = S1.Range("C:C")
        Set Adres2 = S1.Range("J:J")
    ElseIf OptionButton4 = True Then
        Set Adres1 = S1.Range("D:D")
        Set Adres2 = S1.Range("K:K")
    End If
    ListBox1.ColumnCount = 6
    ListBox1.ColumnWidths = "75;75;75;75;75;75"
    ListBox2.ColumnCount = 6
    ListBox2.ColumnWidths = "75;75;75;75;75;75"
    Set Bul = Adres1.Find(TextBox1, , , xlWhole)
    If Not Bul Is Nothing Then
    Adres = Bul.Address
        Do
            ListBox1.AddItem
            ListBox1.List(Satır, 0) = S1.Cells(Bul.Row, "A")
            ListBox1.List(Satır, 1) = S1.Cells(Bul.Row, "B")
            ListBox1.List(Satır, 2) = S1.Cells(Bul.Row, "C")
            ListBox1.List(Satır, 3) = S1.Cells(Bul.Row, "D")
            ListBox1.List(Satır, 4) = S1.Cells(Bul.Row, "E")
            ListBox1.List(Satır, 5) = S1.Cells(Bul.Row, "F")
            Satır = Satır + 1
            Set Bul = Adres1.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
    Satır = 0
    Set Bul = Adres2.Find(TextBox1, , , xlWhole)
    If Not Bul Is Nothing Then
    Adres = Bul.Address
        Do
            ListBox2.AddItem
            ListBox2.List(Satır, 0) = S1.Cells(Bul.Row, "H")
            ListBox2.List(Satır, 1) = S1.Cells(Bul.Row, "I")
            ListBox2.List(Satır, 2) = S1.Cells(Bul.Row, "J")
            ListBox2.List(Satır, 3) = S1.Cells(Bul.Row, "K")
            ListBox2.List(Satır, 4) = S1.Cells(Bul.Row, "L")
            ListBox2.List(Satır, 5) = S1.Cells(Bul.Row, "M")
            Satır = Satır + 1
            Set Bul = Adres2.FindNext(Bul)
        Loop While Not Bul Is Nothing And Bul.Address <> Adres
    End If
    
    Label6.Caption = "Bulunan kayıt sayısı : " & Format(ListBox1.ListCount, "#,##0")
    Label7.Caption = "Bulunan kayıt sayısı : " & Format(ListBox2.ListCount, "#,##0")
    
    Set Bul = Nothing
    Set S1 = Nothing
    Set Adres1 = Nothing
    Set Adres2 = Nothing
    
    MsgBox "Arama işlemi tamamlanmıştır.", vbInformation
End Sub

 

[halit3]

Bende birşeyler yapmıştım boşa gitmesin

Alternatif olsun

Private Sub CommandButton1_Click()
Dim say1 As Long, say2 As Long, Sh As Worksheet, deg1 As Long, deg2 As Long
say1 = 0
say2 = 0
deg1 = 0
deg2 = 8
If OptionButton1.Value = True Then
deg1 = 1
deg2 = 8
ElseIf OptionButton2.Value = True Then
deg1 = 2
deg2 = 9
ElseIf OptionButton3.Value = True Then
deg1 = 3
deg2 = 10
ElseIf OptionButton4.Value = True Then
deg1 = 4
deg2 = 11
End If
If Val(deg1) = 0 Then
MsgBox "LÜTFEN ARANACAK KRİTER TERCİHİNİZİ YAPINIZ", vbExclamation, "Dikkat !"
Exit Sub
End If
If TextBox1 = "" Then
If Val(deg1) = 1 Then
MsgBox "LÜTFEN KİŞİ T.C. GİRİNİZ"
Exit Sub
ElseIf Val(deg1) = 2 Then
MsgBox "LÜTFEN KİŞİ AD SOYAD GİRİNİZ"
Exit Sub
ElseIf Val(deg1) = 3 Then
MsgBox "LÜTFEN ANNE T.C. NUMARASINI GİRİNİZ"
Exit Sub
ElseIf Val(deg1) = 4 Then
MsgBox "LÜTFEN ANNE AD SOYADN GİRİNİZ"
Exit Sub
End If
End If
ListBox1.Clear
ListBox1.ColumnCount = 6
ListBox1.ColumnWidths = "85;70;70;70;70;70"
ListBox2.Clear
ListBox2.ColumnCount = 6
ListBox2.ColumnWidths = "85;70;70;70;70;70"
If TextBox1.Text = "" Then Exit Sub
Set Sh = Sheets("Veri")
'With Sh.Range(Cells(2, 1), Cells(Rows.Count, 12))
With Sh.Range(Cells(3, deg1), Cells(Rows.Count, deg1))
Set d = .Find(What:=TextBox1.Text, After:=.Cells(.Cells.Count), LookIn:=xlValues, lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not d Is Nothing Then
FirstAddress = d.Address
Do
ListBox1.AddItem
ListBox1.List(say1, 0) = Sh.Cells(d.Row, "a").Value
ListBox1.List(say1, 1) = Sh.Cells(d.Row, "b").Value
ListBox1.List(say1, 2) = Sh.Cells(d.Row, "c").Value
ListBox1.List(say1, 3) = Sh.Cells(d.Row, "d").Value
ListBox1.List(say1, 4) = Sh.Cells(d.Row, "e").Value
ListBox1.List(say1, 5) = Sh.Cells(d.Row, "f").Value
say1 = say1 + 1
Set d = .FindNext(d)
Loop While Not d Is Nothing And d.Address <> FirstAddress
End If
End With

With Sh.Range(Cells(3, deg2), Cells(Rows.Count, deg2))
Set c = .Find(What:=TextBox1.Text, After:=.Cells(.Cells.Count), LookIn:=xlValues, lookat:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
ListBox2.AddItem
ListBox2.List(say2, 0) = Sh.Cells(c.Row, "h").Value
ListBox2.List(say2, 1) = Sh.Cells(c.Row, "ı").Value
ListBox2.List(say2, 2) = Sh.Cells(c.Row, "j").Value
ListBox2.List(say2, 3) = Sh.Cells(c.Row, "k").Value
ListBox2.List(say2, 4) = Sh.Cells(c.Row, "l").Value
ListBox2.List(say2, 5) = Sh.Cells(c.Row, "m").Value
say2 = say2 + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With

Set Sh = Nothing
Label6.Caption = "Listelenen : " & Format(ListBox1.ListCount, "#,##0")
Label7.Caption = "Listelenen : " & Format(ListBox2.ListCount, "#,##0")
MsgBox "ARAMA SONUÇLANDI"
End Sub