Çoklu listbox veri ekleme ve yazdırma

[bebar]

Merhaba;
Sorunum hakkında bir çok konu açılmış fakat doğru uygulayamadım, istediğime çok yakın bir örnek buldum dediğim gibi başarılı olamadım, bulduğum örneğin resimlerini kodlarını ayrıca ne istediğimi de ekte paylaştım. yardımcı olursanız çok memnun olurum.
Teşekkür ederim.

 

[Ömer BARAN]

Merhaba.
Sayfaya;
-- bir adet dikdörtgen (belgedeki resimde üzerinde "Seç" veya "Yaz" yazan)
-- bir adet GELİŞTİRİCİ => EKLE => ActiveX Denetimleri bölümünden ListBox ekleyin (adının ListBox1 olduğunda emin olun)

Alt taraftan sayfa adına fareyle sağ tıklayıp KOD GÖRÜNTÜLEyi seçin ve açılan VBA ekranında sağdaki alana aşağıdaki kod'u yapıştırın.
Sayfaya eklediğiniz dikdörtgen şekline sağ tıklayıp MAKRO ATAyı seçin ve açılan küçük ekranda TIKLA makrosunun adını seçerek işlemi onaylayın.

Eğer yazma işlemi;
-- her defasında K2'den başlayacaksa (bu, önceden yazılmış olanlar silinecek demek) kırmızı olan satırı silin,
-- K sütunundaki ilk boş hücreden başlayacaksa da mavi olan satırları silin.

Sub TIKLA()
Dim sek As Shape, lst As Variant, I As Integer
Set sek = ActiveSheet.Shapes(Application.Caller)
Set lbx = ActiveSheet.ListBox1

If lbx.Visible = False Then
    lbx.Visible = True
    sek.TextFrame2.TextRange.Characters.Text = "Yaz"
Else
    lbx.Visible = False
    sek.TextFrame2.TextRange.Characters.Text = "Seç"
    [K:K].ClearContents
    sat = 1
    For I = 1 To lbx.ListCount - 1
        If lbx.Selected(I) = True Then
            sat = sat + 1
            sat = Cells(Rows.Count, "K").End(3).Row + 1
            Cells(sat, "K") = lbx.List(I)
        End If
    Next I
End If
lbx.MultiSelect = 0
lbx.MultiSelect = 1

End Sub

 

[bebar]

Hocam çok teşekkür ederim. Çok faydası oldu