Soru listbox'dan çift tıkla listbox'a veri aktarma

[yasarcan]

Yeni çalışmamda desteğinizi isteyeceğim. Çalışma içerisinde Userform ve açıklama mevcut.
Şimdiden teşekkürler

 

[YUSUF44]

Aşağıdaki kodları userforma ekleyip deneyin. (Çift tık değil de tek tık olarak ayarladım)

Private Sub L1_Change()

If L2.ListCount > 0 Then
    For i = 0 To L2.ListCount - 1
        If L2.List(i) = L1.Value Then
            GoTo 10
        End If
    Next
End If
L2.AddItem L1.Value
10:
End Sub

Private Sub L2_Change()
Set s1 = Sheets("ÇEKLİST")
son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "B").End(3).Row)

Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
L3.Clear
For i = 0 To L2.ListCount - 1
    If L2.Selected(i) Then
        sorgu = "select distinct İÇERİK from [ÇEKLİST$] where KONU='" & L2.List(i) & "'"
        Set rs = con.Execute(sorgu)
        L3.Column = rs.getrows
    End If
Next

End Sub

Private Sub UserForm_Initialize()
Set s1 = Sheets("ÇEKLİST")
son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "B").End(3).Row)

Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select distinct KONU from [ÇEKLİST$] where KONU is not null"
Set rs = con.Execute(sorgu)

L1.Column = rs.getrows
End Sub

 

[yasarcan]

Teşekkür ederim.
Tam istediğim gibi oldu.
Üstüne çalışacağım şeyse son listbox da işaretlediğim maddeleri kaydetmek ve istediğimde geri çağırmak. Biraz çalışayım.

 

[YUSUF44]

Kodun en başında bir satırı eksik kopyalamışım, ona dikkat edin lütfen. Önceki mesajımı düzelttim.

 

[yasarcan]

Onu anladım çözdüm ancak mevcutta kullandığım yazdır ( ki oda listbox) koduyla çakıştı. bu çalışırken o duruyor. ben düzeltmeye çalışayım yoksa buna ayrı bir userform oluşturup sayfa değiştireyim.

 

[yasarcan]

Option Explicit
Dim i          As Integer

Private Sub chkAll_Click()
    For i = 1 To lbxSheets.ListCount
        Me.lbxSheets.Selected(i - 1) = Me.chkAll.Value
    Next i
End Sub

Private Sub cmbCancel_Click()
    Unload Me
End Sub

Private Sub cmbPrint_Click()
    For i = 1 To Me.lbxSheets.ListCount
        If Me.lbxSheets.Selected(i - 1) = True Then
            If Me.chkPreview Then
                Me.Hide
                Sheets(Me.lbxSheets.List(i - 1, 0)).PrintPreview
                Me.lbxSheets.Selected(i - 1) = False
            Else
                Sheets(Me.lbxSheets.List(i - 1, 0)).PrintOut
                Me.lbxSheets.Selected(i - 1) = False
            End If
        End If
    Next i
End Sub

Private Sub UserForm_Initialize()
    Dim oWs    As Worksheet
    For Each oWs In Sheets
        If oWs.Type = 3 Then    'Chart sheet
            Me.lbxSheets.AddItem oWs.Name
            'exclude empty sheets
        ElseIf WorksheetFunction.CountA(oWs.Cells) > 0 Then
            Me.lbxSheets.AddItem oWs.Name
        End If
    Next oWs
End Sub

Bu kodla ortak userformda lbxSheets isimli listbox çalışmıyor.

 

[YUSUF44]

Dosyayı görmeden, denemeden bilemem maalesef.

 

[yasarcan]

Ben biraz toparlayayım ne yapmaya çalıştığımı da izah edeyim sonra paylaşayım hocam. şimdilik çok teşekkürler

 

[yasarcan]

Hocam nerede hata yapıyorum ben?

 

[YUSUF44]

Formda iki tane Initialize kodu var. Birden fazla olamayacağı için benim önerdiğim dışındakini sildim.

Kodların arasında, ortada bir yerde Option Exclipit var, onun ya kodların en üstünde olması ya da hiç olmaması gerekiyor, onu sildim.

O satırın altında da yine herhangi bir kod bloğunun içinde olmayan Dim tanımları vardı, o satırı da sildim ve form düzgün çalıştı.

 

[yasarcan]

teşekkür ederim.

 

[yasarcan]

hocam aklıma gelen fikirler var bazılarını yapabilirim sanırım fakat önce danışayım uygulamam mümkün mü ?
1.L2 ye yolladığımız konuyu yanlış yolladıysak sağ tık ile L2 den kaldırmamız (ancak çeklistte silinmicek)
2.L3 de kutucuk şeklinde seçtiğim içerikleri : seçince örneğin sayfa3 de a2 hücresine "a" yazması işareti kaldırınca a3 hücresine a yazması.
3.Çalışmayı kaydedip çıktığımda L3 e kadar işaretli seçeneklerin işaretli gelmesi
4.L2 ye çektiğim L1 deki konudan bir tane daha lazımsa L1 e tıklayarak bir tane daha eklemesi fakat adına +1+2+3 diye eklenti yaparak Çeklistte en son satıra kendini ve içeriğini çoğaltarak kopyalaması.

 

[yasarcan]

2.maddenin çözümünü anladım. Ancak verdiğiniz kodlarla birleştirmeyi başaramadım.
1.ve 3. madde üzerinde araştırıyorum. 4 başka zaman inş.