• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Çoklu listbox veri ekleme ve yazdırma

  • Konbuyu başlatan Konbuyu başlatan bebar
  • Başlangıç tarihi Başlangıç tarihi
Katılım
12 Kasım 2014
Mesajlar
255
Excel Vers. ve Dili
2013
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.
 

Ekli dosyalar

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.
Rich (BB code):
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
 
Hocam çok teşekkür ederim. Çok faydası oldu
 
Geri
Üst