Comboboxtan seçerek listboxa bilgileri aktarma

[Bosnalı Yasemin]

Merhaba. Tüm forumda aradım hatta excelle ilgili başka sitelere baktım fakat bulamadım veya gözümden kaçtı. Bilgilerin olduğu ana tablo var ve bu tablodaki isimleri/sicilleri seçerek listboxa karşılarındaki bilgileri aktarmak istiyorum fakat yaptıramadım. Bu yazdığım olayı fonksiyonları kullanarak (özellikle düşeyaranın çoklu sonuç getirme mantığıyla olabiliyor) kısmende olsa yapabiliyorum fakat olayı makrolar ile daha süratli olması amacıyla yaptırmak istiyorum. Lütfen yardımcı olur musunuz ?

 

[Orion1]

Dosyanız hazır.

Option Base 1
Private Sub CommandButton1_Click()
Call listele(ComboBox1, 1)
End Sub

Private Sub CommandButton2_Click()
Call listele(ComboBox2, 2)

End Sub

Private Sub CommandButton3_Click()
Call listele(ComboBox3, 3)

End Sub

Private Sub CommandButton4_Click()
Dim sh As Worksheet, sat As Long
Set sh = Sheets("Yazdir")
sh.Range("A2:H65536").Clear
If ListBox1.ListCount < 1 Then
    MsgBox "Yazdırmak için listelenen veri yok", vbCritical, "UYARI"
    Exit Sub
End If
sh.Range("A2").Resize(ListBox1.ListCount, 8) = ListBox1.List
sh.PageSetup.PrintArea = "Yazdir!B2:H" & ListBox1.ListCount + 1
Me.Hide
On Error Resume Next
sh.PrintPreview
Me.Show
End Sub

Private Sub ListBox1_Click()

End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()
Dim liste(), a As Long, b As Long, sh As Worksheet, kurs As String
Dim z1 As Object, z2 As Object, z3 As Object, i As Long, myarr(), myarr2()
Me.Caption = "evrengizlen@hotmail.com      " & Format(Now, "dd mmmm yyyy  dddd   hh:mm")
ComboBox1.Clear: ComboBox2.Clear
Set sh = Sheets("Sheet1")
sat = sh.Cells(65536, "A").End(xlUp).Row
If sat < 2 Then Exit Sub: Set sh = Nothing
Set z1 = CreateObject("Scripting.Dictionary")
Set z2 = CreateObject("Scripting.Dictionary")
Set z3 = CreateObject("Scripting.Dictionary")

liste = sh.Range("A2:C" & sat).Value
ReDim myarr(1 To 1, 1 To sat)
ReDim myarr2(1 To 1, 1 To sat)
For i = 1 To UBound(liste, 1)
    isim = UCase(Replace(Replace(liste(i, 2), "i", "İ"), "ı", "I"))
    kurs = UCase(Replace(Replace(liste(i, 3), "i", "İ"), "ı", "I"))
    If Not z1.exists(liste(i, 1)) Then
        z1.Add liste(i, 1), Nothing
    End If
    If Not z2.exists(isim) Then
        a = a + 1
        z2.Add isim, Nothing
        myarr(1, a) = liste(i, 2)
    End If
    If Not z3.exists(kurs) Then
        b = b + 1
        z3.Add kurs, Nothing
        myarr2(1, b) = liste(i, 3)
    End If
Next i
Erase liste
Call listele(ComboBox2, 2)
If z1.Count > 0 Then
    ComboBox1.List = Application.Transpose(Array(z1.keys))
    ComboBox1.ListIndex = 0
End If
Set z1 = Nothing
If a > 0 Then
    ReDim Preserve myarr(1 To 1, 1 To a)
    ComboBox2.Column = myarr
    ComboBox2.ListIndex = 0
End If
Set z2 = Nothing: Erase myarr
If b > 0 Then
    ReDim Preserve myarr2(1 To 1, 1 To b)
    ComboBox3.Column = myarr2
    ComboBox3.ListIndex = 0
End If
Set z3 = Nothing: Erase myarr2

End Sub
Sub listele(ByVal comb As Control, sut As Integer)
Dim deg As Variant, myarr(), adr, k As Range, sh As Worksheet, sat As Long
Dim j As Integer, a As Long
ListBox1.Clear
Label4.Caption = "Listelenen : " & Format(0, "#,##0") & " Adet"
Set sh = Sheets("Sheet1")
sat = sh.Cells(65536, "A").End(xlUp).Row
If sat < 2 Then Exit Sub: Set sh = Nothing
If IsNumeric(comb.Text) Then
    deg = CDbl(comb.Text)
    Else
    deg = comb.Text & "*"
End If
ReDim myarr(1 To 8, 1 To sat)
Set k = sh.Range(sh.Cells(2, sut), sh.Cells(sat, sut)).Find(deg, , xlValues, xlWhole)
If Not k Is Nothing Then
    adr = k.Address
    Do
        a = a + 1
        myarr(1, a) = k.Row
        For j = 1 To 7
            myarr(j + 1, a) = sh.Cells(k.Row, j).Value
        Next j
        Set k = sh.Range(sh.Cells(2, sut), sh.Cells(sat, sut)).FindNext(k)
    Loop While Not k Is Nothing And k.Address <> adr
    ReDim Preserve myarr(1 To 8, 1 To a)
    ListBox1.Column = myarr
End If
Erase myarr
Label4.Caption = "Listelenen : " & Format(ListBox1.ListCount, "#,##0") & " Adet"

Set sh = Nothing
End Sub

 

[Bosnalı Yasemin]

Size çok teşekkür ederim. Allah razı olsun.Bir sorum daha olacak.Asıl projemde bilgi sütunları G'ye kadar gidiyor. Bu olayı G sütununa kadar nasıl genişletebilirim. Kodlar benim için gerçekten çok karışık. Neyi nereye uygulayabileceğim sanırım çok zor olacak.

 

[Orion1]

Size çok teşekkür ederim. Allah razı olsun.Bir sorum daha olacak.Asıl projemde bilgi sütunları G'ye kadar gidiyor. Bu olayı G sütununa kadar nasıl genişletebilirim. Kodlar benim için gerçekten çok karışık. Neyi nereye uygulayabileceğim sanırım çok zor olacak.

Ben hallettim.
Siz kafanızı takmayın.
Dosyanız 2 numaralı mesajdadır.