Listboxa Koşullu Benzersiz Veri Alma

[metin_0606]

Değerli forum üyeleri çalışmamda C2:C sütununda bulunan benzersiz verileri listboxa çekiyorum. Ancak bu makroya "I "sütununda "Aktif" yazan benzersiz verileri getirme koşulunu eklemek istiyorum. Bu konuda yardımlarınızı bekliyorum. Saygılar

 

[Ziynettin]

Sizin kod.

Private Sub CommandButton1_Click()
On Error Resume Next
ListBox1.Clear
Set s = Sheets("ANA LISTE")
    For i = 2 To s.[A65536].End(3).Row
        If s.Range("I" & i) = "AKTİF" Then
            If WorksheetFunction.CountIf(s.Range("C2:C" & i), s.Cells(i, "C")) Then
                ListBox1.AddItem s.Cells(i, "C").Value
            End If
        End If
    Next i
End Sub

Hız açısında alternatif kod.

Private Sub CommandButton1_Click()
ListBox1.Clear
Set s = Sheets("ANA LISTE")
Set dc = CreateObject("scripting.dictionary")
son = s.[A65536].End(3).Row
    If son < 2 Then Exit Sub
    tbl = s.Range("A1:I" & son).Value
    For i = 2 To son
        If tbl(i, 9) = "AKTİF" Then
            dc(tbl(i, 3)) = ""
        End If
    Next i
If dc.Count > 0 Then ListBox1.List = dc.keys
End Sub

 

[Korhan Ayhan]

Alternatif;

Private Sub CommandButton1_Click()
    Dim Baglanti As Object

    Set Baglanti = CreateObject("AdoDb.Connection")

    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
     
    ListBox1.Column = Baglanti.Execute("Select Distinct F3 From [ANA LISTE$] Where F9 = 'AKTİF' Order By F3 Asc").GetRows

    Baglanti.Close
    Set Baglanti = Nothing
End Sub

 

[metin_0606]

Sizin kod.

Private Sub CommandButton1_Click()
On Error Resume Next
ListBox1.Clear
Set s = Sheets("ANA LISTE")
    For i = 2 To s.[A65536].End(3).Row
        If s.Range("I" & i) = "AKTİF" Then
            If WorksheetFunction.CountIf(s.Range("C2:C" & i), s.Cells(i, "C")) Then
                ListBox1.AddItem s.Cells(i, "C").Value
            End If
        End If
    Next i
End Sub

Hız açısında alternatif kod.

Private Sub CommandButton1_Click()
ListBox1.Clear
Set s = Sheets("ANA LISTE")
Set dc = CreateObject("scripting.dictionary")
son = s.[A65536].End(3).Row
    If son < 2 Then Exit Sub
    tbl = s.Range("A1:I" & son).Value
    For i = 2 To son
        If tbl(i, 9) = "AKTİF" Then
            dc(tbl(i, 3)) = ""
        End If
    Next i
If dc.Count > 0 Then ListBox1.List = dc.keys
End Sub

Teşekkürler ziynettin hocam istenilen sonucu verdi

 

[metin_0606]

Alternatif;

Private Sub CommandButton1_Click()
    Dim Baglanti As Object

    Set Baglanti = CreateObject("AdoDb.Connection")

    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0;Hdr=No"""
    
    ListBox1.Column = Baglanti.Execute("Select Distinct F3 From [ANA LISTE$] Where F9 = 'AKTİF' Order By F3 Asc").GetRows

    Baglanti.Close
    Set Baglanti = Nothing
End Sub

Teşekkürler Korhan hocam istediğim sonucu verdi

 

[metin_0606]

Değerli üstatlar aynı form üzerinden yine ANA LISTE isimli sayfanın I sütununda AKTİF yazan verileri textbox1'e nasıl saydırabilirim.

 

[Korhan Ayhan]

Deneyiniz.

TextBox1 = WorksheetFunction.Countif(Sheets("ANA LISTE").Range("I:I"), "AKTİF")

 

[metin_0606]

Deneyiniz.

TextBox1 = WorksheetFunction.Countif(Sheets("ANA LISTE").Range("I:I"), "AKTİF")

Teşekkürler Korhan hocam