ListBoxta multiselect yoluyla çoklu veri girme

[Feylosof]

Merhaba excel dostları;

Daha önce bu forumdan bulduğum ve geliştirmek için yine sizlerden yardım aldığım bir dosyaya yeni bir özellik daha eklemek istiyorum.
UserFormda iki adet listbox mevcut birincisinde multi select özelliği mevcut. ikincisine de aynı özelliği eklemek istiyorum.
Dosyayı paylaşıyorum.

 

[Feylosof]

...

 

[Ziynettin]

Merhaba.

Listbox2 properties alnından MultiSelect = fmMultiSelectMulti olarak ayarlayın.

Ya da;

Formun initalize yordamına aşağıdaki kodu uygulayın.

Private Sub UserForm_Initialize()
    ListBox2.MultiSelect = fmMultiSelectMulti
End Sub

 

[EmrExcel16]

Merhaba , @Ziynettin beyin belirtmiş olduğu ayarları da yapın. Olmaz ise formdaki kodları silin ve aşağıdaki verdiğim kodları yapıştırın .

Option Explicit
Private Sub CommandButton1_Click()
    Dim s1, s2, s, x, y, kisibul, Tarihbul
    Set s1 = Sheets("Çizelge")
    Set s2 = Sheets("Tarih")
    s = 0
    For x = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(x) = True Then
            Set kisibul = s1.Range("B7:B31").Find(ListBox1.List(x), , xlValues, xlWhole)
            If Not kisibul Is Nothing Then
                For y = 0 To ListBox2.ListCount - 1
                    If ListBox2.Selected(y) = True Then
                        Set Tarihbul = s1.Range(s1.Cells(6, 4), s1.Cells(6, s1.Cells(6, s1.Columns.Count).End(1).Column)).Find(CDate(ListBox2.List(y)), , xlValues, xlWhole)
                        If Not Tarihbul Is Nothing Then
                            s1.Cells(kisibul.Row, Tarihbul.Column) = "Derse Girdi"
                            s = s + 1
                        End If
                    End If
                Next y
            End If
        End If
    Next x
    If s = 0 Then
        MsgBox "Bilgi bulunamadı."
        Exit Sub
    End If
    MsgBox "Bilgi girişi tamamlanmıştır."
End Sub

Private Sub CommandButton2_Click()
    Dim s1, s2, s, x, y, kisibul, Tarihbul
    Set s1 = Sheets("Çizelge")
    Set s2 = Sheets("Tarih")
    s = 0
    For x = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(x) = True Then
            Set kisibul = s1.Range("B7:B31").Find(ListBox1.List(x), , xlValues, xlWhole)
            If Not kisibul Is Nothing Then
                For y = 0 To ListBox2.ListCount - 1
                    If ListBox2.Selected(y) = True Then
                        Set Tarihbul = s1.Range(s1.Cells(6, 4), s1.Cells(6, s1.Cells(6, s1.Columns.Count).End(1).Column)).Find(CDate(ListBox2.List(y)), , xlValues, xlWhole)
                        If Not Tarihbul Is Nothing Then
                            s1.Cells(kisibul.Row, Tarihbul.Column) = "Derse Girmedi"
                            s = s + 1
                        End If
                    End If
                Next y
            End If
        End If
    Next x
    If s = 0 Then
        MsgBox "Bilgi bulunamadı."
        Exit Sub
    End If
    MsgBox "Bilgi girişi tamamlanmıştır."
End Sub

 

[Feylosof]

@Ziynettin hocam çok teşekkür ederim.

 

[Feylosof]

@EmrExcel16 Değerli üstadım teşekkürler. Hızır gibisiniz.

 

[Feylosof]

Her iki cevabı eve dönünce inceleme fırsatı bulunca şunu farkettim. Sayın @Ziynettin hocamın cevabı listboxlara multiselect özelliğ veriyor. Ancak veri girişlerine etki etmiyor.
Sayın @EmrExcel16 hocamın hem birinci özelliği ile hem de veri aktarma yönünden tam istediğim gibi olmuş. eşekkürler.

 

[EmrExcel16]

Rica ederim , bilğilendirme için teşekkür ederim , önemli olan sorununuzun çözülmesidir. İyi çalışmalar.