koşullu listbox

Schuba · 30 Aralık 2018

merabalar

değerli hocalaraım koşula bağlı listboxl'a alakalı yardıma ihtiyacım var yardımcı olursanız sevinirim

ekli dosyada açıklamaları mevcuttur..

Orion1 · 30 Aralık 2018

Kodlar çalışma sayfasının modülüne yazılmıştır.
Listbox ın özelliğinden columncount özelliğini 10 yapınız.
Buyurun.

Dosyanız ektedir.

Kod:

Sub listele59()
Dim sh As Worksheet, i As Long, sonsat As Long, x As Long
Dim k As Integer
Set sh = Sheets("TABLO")
ListBox1.Clear
sonsat = sh.Cells(Rows.Count, "B").End(xlUp).Row
For i = 5 To sonsat
    If sh.Cells(i, "B").Value = Range("D3").Value Then
        ListBox1.AddItem
        For k = 0 To 7
            ListBox1.List(x, k) = sh.Cells(i, k + 3).Value
        Next k
        ListBox1.List(x, 8) = VBA.FormatCurrency(sh.Cells(i, "K").Value, 2)
        x = x + 1
    End If
Next i
End Sub

askm · 30 Aralık 2018

Aşağıdaki kodları sayfanın kod bölümüne ekleyip deneyin.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D3]) Is Nothing Then Exit Sub
With Worksheets("LİSTE").OLEObjects("ListBox1").Object
    .Clear
    .ColumnCount = 10
    .ColumnWidths = "50;50;50;50;50;50;50;50;50;50"
    .IntegralHeight = False
For askm = 5 To 19
    If Sheets("TABLO").Cells(askm, 2) = Target.Value Then
        .AddItem
        For i = 2 To 11
            .List(X, i - 2) = Sheets("TABLO").Cells(askm, i).Value
        Next i
        X = X + 1
    End If
Next askm
End With
End Sub

Schuba · 30 Aralık 2018

değerli hocalarım ellerinize sağlık çok çok güzel olmuş sağolun...

bide rica etsem "birden çok sütunda ölçüt aramak" diye bir konum vardı cevap veren olmadı bir baksanız..

dosyayı ekledim açıklama içine yazıyor..

askm · 30 Aralık 2018

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D4]) Is Nothing Then Exit Sub
    Dim s1 As Worksheet, s2 As Worksheet
    Dim Satir As Integer
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    Set deger = s1.Range("E5:H17").Find(Target.Value)
    If deger Is Nothing Then
        s2.Range("H10").Value = "Aranan değer yok!"
    Else
        Satir = deger.Row
        s2.Range("D7").Value = s1.Cells(Satir, 2).Value
        s2.Range("D8").Value = s1.Cells(Satir, 3).Value
        s2.Range("D9").Value = s1.Cells(Satir, 4).Value
        s2.Range("F7").Value = s1.Cells(Satir, 5).Value
        s2.Range("F8").Value = s1.Cells(Satir, 6).Value
        s2.Range("F9").Value = s1.Cells(Satir, 7).Value
        s2.Range("F10").Value = s1.Cells(Satir, 8).Value
        s2.Range("H7").Value = s1.Cells(Satir, 9).Value
        s2.Range("H8").Value = s1.Cells(Satir, 10).Value
    End If
End Sub

Hakan ERDOST · 30 Aralık 2018

Formülle düzenlenmesini istediğiniz şekli de ekte.

Schuba · 31 Aralık 2018

hexadesimal' Alıntı:
Formülle düzenlenmesini istediğiniz şekli de ekte.

hocam siszin formülle yaptığınız güzel fakat dikkat ederseniz birden fazla sütunu ölçüt alanı olarak kullanacak demiştim
sizin yaptığınızada sadece sayfa 1'deki ( "telefon 1") sütununu ölçüt alanı olarak kullanıyor
örneyin ("telefon 2") veya ("telefon 3") sütunundaki bir numarayı girdiğim zaman bulamıyor yanı sarı alanın tamamını ölçüt alanı olarak kullanacak.

Schuba · 31 Aralık 2018

askm' Alıntı:

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D4]) Is Nothing Then Exit Sub
    Dim s1 As Worksheet, s2 As Worksheet
    Dim Satir As Integer
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    Set deger = s1.Range("E5:H17").Find(Target.Value)
    If deger Is Nothing Then
        s2.Range("H10").Value = "Aranan değer yok!"
    Else
        Satir = deger.Row
        s2.Range("D7").Value = s1.Cells(Satir, 2).Value
        s2.Range("D8").Value = s1.Cells(Satir, 3).Value
        s2.Range("D9").Value = s1.Cells(Satir, 4).Value
        s2.Range("F7").Value = s1.Cells(Satir, 5).Value
        s2.Range("F8").Value = s1.Cells(Satir, 6).Value
        s2.Range("F9").Value = s1.Cells(Satir, 7).Value
        s2.Range("F10").Value = s1.Cells(Satir, 8).Value
        s2.Range("H7").Value = s1.Cells(Satir, 9).Value
        s2.Range("H8").Value = s1.Cells(Satir, 10).Value
    End If
End Sub

hocam sizin yaptığınız tam istediğim gibi süper olmuş ellerinize sağlık

fakat sizden 3 tane düzeltme istiyicem mümkünse

1) : hücreye boş veri girdiğinde veya hücrenin içi temizlendiğinde diyer hücrelerde boşalsın boş görünsün..

2) : listede olmayan bir telefon numarası girildiğine bir önceki veriler hücrelerde kalıyor temizlenmiyor benim istediğim ise girilen telefon
numarası eyer listede yoksa daha önce hücrelerde kalan bilgiler temizlensin boş görünsün..

3) : tam eşleşme sağlayabilirmiyiz yani hücreye örneğin "2" yazdığım zaman içinde "2" geçen telefon numarası varsa o telefon numarasının bilgilerinide çekiyor
benim istediğim ise tam eşleşme olmuyorsa hiç birşey çekmesin boş bıraksın

askm · 31 Aralık 2018

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D4]) Is Nothing Then Exit Sub
    Dim s1 As Worksheet, s2 As Worksheet
    Dim Satir As Integer
    Set s1 = Sheets("Sayfa1")
    Set s2 = Sheets("Sayfa2")
    Application.ScreenUpdating = False
    temizle
    If Target = "" Then temizle
    Set deger = s1.Range("E5:H17").Find(Target.Value, LookAt:=xlWhole)
    If deger Is Nothing Then
        s2.Range("H10").Value = "Aranan değer yok!"
    Else
        Satir = deger.Row
        s2.Range("D7").Value = s1.Cells(Satir, 2).Value
        s2.Range("D8").Value = s1.Cells(Satir, 3).Value
        s2.Range("D9").Value = s1.Cells(Satir, 4).Value
        s2.Range("F7").Value = s1.Cells(Satir, 5).Value
        s2.Range("F8").Value = s1.Cells(Satir, 6).Value
        s2.Range("F9").Value = s1.Cells(Satir, 7).Value
        s2.Range("F10").Value = s1.Cells(Satir, 8).Value
        s2.Range("H7").Value = s1.Cells(Satir, 9).Value
        s2.Range("H8").Value = s1.Cells(Satir, 10).Value
    End If
    Application.ScreenUpdating = True
End Sub

Sub temizle()
Range("D7").Value = Empty
Range("D8").Value = Empty
Range("D9").Value = Empty
Range("F7").Value = Empty
Range("F8").Value = Empty
Range("F9").Value = Empty
Range("F10").Value = Empty
Range("H7").Value = Empty
Range("H8").Value = Empty
Range("H10").Value = Empty
End Sub

Schuba · 31 Aralık 2018

hocam elinize kolunuza sağlık süper oldu

yanlız bu daha önce gönderdiğiniz "koşullu listebox" ile alakalı kodu orjinal dosyama uyarlıyamadım
önceki gönderdiğim örnek dosyada gayet güzel çalışıyor fakat orjinal dosyamda hata veriyor ve sadece 10 kolonu çekiyor benim 18 kolonum var acaba 10 kolon sınırımı var
orjinal dosyam ektedir bir bakabilirmisiniz ..

askm · 31 Aralık 2018

Additem yönteminde 10 kolon sınırı vardır.
Bunu aşmak için ya aşağıdaki gibi Gecici diye bir sayfa kullanıp list yöntemi ile eklemeniz gerek.
.List = Sheet("Gecici").Range("A1:R" & Cells(65536, "A").End(xlUp).Row).Value
Ya da dizi kullanmanız gerekir. Aşağıdaki gibi.
Yalnız sütun boyutunu yeniden ayarlamanız gerekli. 50 olarak verilen değerleri değiştirmeniz gerek.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D6]) Is Nothing Then Exit Sub
ReDim dizi(1 To 18, 1 To 1)
With Worksheets("MÜŞTERİ CARİSİ").OLEObjects("ListBox1").Object
    .Clear
    .ColumnCount = 18
    .ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50"
    .IntegralHeight = False
For askm = 22 To 10000
    If Sheets("TEKNİK SERVİS").Cells(askm, 2) = Target.Value Then
        x = x + 1
        ReDim Preserve dizi(1 To 18, 1 To x)
        For i = 2 To 19
             dizi(i - 1, x) = Sheets("TEKNİK SERVİS").Cells(askm, i).Value
        Next i
    End If
Next askm
.Column = dizi
End With
End Sub

Schuba · 31 Aralık 2018

askm' Alıntı:
Additem yönteminde 10 kolon sınırı vardır.
Bunu aşmak için ya aşağıdaki gibi Gecici diye bir sayfa kullanıp list yöntemi ile eklemeniz gerek.
.List = Sheet("Gecici").Range("A1:R" & Cells(65536, "A").End(xlUp).Row).Value
Ya da dizi kullanmanız gerekir. Aşağıdaki gibi.
Yalnız sütun boyutunu yeniden ayarlamanız gerekli. 50 olarak verilen değerleri değiştirmeniz gerek.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, [D6]) Is Nothing Then Exit Sub ReDim dizi(1 To 18, 1 To 1) With Worksheets("MÜŞTERİ CARİSİ").OLEObjects("ListBox1").Object .Clear .ColumnCount = 18 .ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50" .IntegralHeight = False For askm = 22 To 10000 If Sheets("TEKNİK SERVİS").Cells(askm, 2) = Target.Value Then x = x + 1 ReDim Preserve dizi(1 To 18, 1 To x) For i = 2 To 19 dizi(i - 1, x) = Sheets("TEKNİK SERVİS").Cells(askm, i).Value Next i End If Next askm .Column = dizi End With End Sub

Hocam bu gönderdiğiniz kodu sayfanın kod bölümüne yapıştırdım gayet güzel çalışıyor başka birşey yapmama gerek kalmadı

sadece tarihleri biraz farklı çekiyor yani "28 / 05 / 2018" olması gereken tarihi "05 / 28 / 2018" olarak çekiyor
bunun bir ayarı varmıdır listbox'ın ayar menüsünde

son olarak "120" yerine "120 TL" para birimi gibi biçimlendirmeler yapılabiliyormu yoksa böylemi olması gerekiyor.

askm · 31 Aralık 2018

Aşağıdaki şekilde şart ekleyerek yapabilirsiniz

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D6]) Is Nothing Then Exit Sub
ReDim dizi(1 To 18, 1 To 1)
With Worksheets("MÜŞTERİ CARİSİ").OLEObjects("ListBox1").Object
    .Clear
    .ColumnCount = 18
    .ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50"
    .IntegralHeight = False
For askm = 22 To 10000
    If Sheets("TEKNİK SERVİS").Cells(askm, 2) = Target.Value Then
        x = x + 1
        ReDim Preserve dizi(1 To 18, 1 To x)
        For i = 2 To 19
            If i = 4 Then
                dizi(i - 1, x) = Format(Sheets("TEKNİK SERVİS").Cells(askm, i).Value, "DD.MM.YYYY")
            ElseIf i = 19 Then
                dizi(i - 1, x) = VBA.FormatCurrency(Sheets("TEKNİK SERVİS").Cells(askm, i).Value, 2)
            Else
                dizi(i - 1, x) = Sheets("TEKNİK SERVİS").Cells(askm, i).Value
            End If
        Next i
    End If
Next askm
.Column = dizi
End With
End Sub

Schuba · 23 Şubat 2019

askm' Alıntı:

Aşağıdaki şekilde şart ekleyerek yapabilirsiniz

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [D6]) Is Nothing Then Exit Sub
ReDim dizi(1 To 18, 1 To 1)
With Worksheets("MÜŞTERİ CARİSİ").OLEObjects("ListBox1").Object
    .Clear
    .ColumnCount = 18
    .ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50"
    .IntegralHeight = False
For askm = 22 To 10000
    If Sheets("TEKNİK SERVİS").Cells(askm, 2) = Target.Value Then
        x = x + 1
        ReDim Preserve dizi(1 To 18, 1 To x)
        For i = 2 To 19
            If i = 4 Then
                dizi(i - 1, x) = Format(Sheets("TEKNİK SERVİS").Cells(askm, i).Value, "DD.MM.YYYY")
            ElseIf i = 19 Then
                dizi(i - 1, x) = VBA.FormatCurrency(Sheets("TEKNİK SERVİS").Cells(askm, i).Value, 2)
            Else
                dizi(i - 1, x) = Sheets("TEKNİK SERVİS").Cells(askm, i).Value
            End If
        Next i
    End If
Next askm
.Column = dizi
End With
End Sub

Askm hocam bu daha önceden yardımcı olduğunuz konu hakkında sizden bir ricam olacak
Bu listbox ile alakalı gönderdiğiniz kodu aktif bir şekilde kullanıyorum çokta işime yarıyor teşekkür ederim lakin şöyle bir sorun var

("D6") hücresine girdiğim müşteri numarasına (cari koduna) ait bilgiler hızlı bir şekilde listbox 'ta listeleniyor çok güzel çalışıyor burda hiçbir sorun yok

Fakat listbox 'ın kaynak olarak kullandığı ("D6") hücresinin içini temizlediğim zaman excell baya bir kasıyor yaklaşık 10-15saniye kadar beklemek zorunda kalıyorum
İşin kötü yanı listbox 'ın bulunduğu formu verileri görüntülemenin dışında aynı zamanda müşteri listeme veri girmek içinde kullanıyorum dolayısıyla yeni kayıt gireceğim zaman
"yeni kayıt gir" isimli butunuma tıklayınca butona yazilmiş olan kodum formdaki önceden kalma bilgileri temizliyor ve yeni veri girişi için formu hazırlıyor
Dolayısıyla listbox ın kaynak olarak kullandığı ("D6") hücresinide herseferinde temizlemiş oluyor tamda bu noktada ("D6") hücresi temizlenirken programın sıtabil bir şekilde çalışmasını engelliyor.

Sebebine gelince listbox ın kaynak olarak kullandığı ("D6") hücresi temizlendiğin de listbox haliyle tetiklenmiş oluyor ve ("D6") hücresi artık boş olduğu için TEKNİK SERVİS sayfasındaki ilgili sütunda boş olan hücreleri listeliyor boş olan hücrelerde haliyle çok fazla olduğu için işlem uzun sürüyor ve excell kasma yapıyor

Sizden istediğime gelince nasıl olacak bilmiyorum ama şuanki mevcut koda ilave yapabilirseniz
("D6") hücresi temizlendiğin'de listbox listeleme yapmasın yani çalışmasın
ama içindeki önceden kalma veriler temizlensin yanı listbox boş görünsün

Konuyla ilgili yardimınız için şimdiden teşekkür ederim..

askm · 24 Şubat 2019

Kodları aşağıdaki şekilde revize ederseniz hız etkilemiyor.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If [D6] = Empty Then Worksheets("MÜŞTERİ CARİSİ").OLEObjects("ListBox1").Object.Clear: Exit Sub
If Intersect(Target, [D6]) Is Nothing Then Exit Sub
ReDim dizi(1 To 18, 1 To 1)
With Worksheets("MÜŞTERİ CARİSİ").OLEObjects("ListBox1").Object
    .Clear
    .ColumnCount = 18
    .ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50"
    .IntegralHeight = False
For askm = 22 To 10000
    If Sheets("TEKNİK SERVİS").Cells(askm, 2) = Target.Value Then
        x = x + 1
        ReDim Preserve dizi(1 To 18, 1 To x)
        For i = 2 To 19
            If i = 4 Then
                dizi(i - 1, x) = Format(Sheets("TEKNİK SERVİS").Cells(askm, i).Value, "DD.MM.YYYY")
            ElseIf i = 19 Then
                dizi(i - 1, x) = VBA.FormatCurrency(Sheets("TEKNİK SERVİS").Cells(askm, i).Value, 2)
            Else
                dizi(i - 1, x) = Sheets("TEKNİK SERVİS").Cells(askm, i).Value
            End If
        Next i
    End If
Next askm
.Column = dizi
End With
End Sub

Schuba · 25 Şubat 2019

askm' Alıntı:

Kodları aşağıdaki şekilde revize ederseniz hız etkilemiyor.

Kod:

Private Sub Worksheet_Change(ByVal Target As Range)
If [D6] = Empty Then Worksheets("MÜŞTERİ CARİSİ").OLEObjects("ListBox1").Object.Clear: Exit Sub
If Intersect(Target, [D6]) Is Nothing Then Exit Sub
ReDim dizi(1 To 18, 1 To 1)
With Worksheets("MÜŞTERİ CARİSİ").OLEObjects("ListBox1").Object
    .Clear
    .ColumnCount = 18
    .ColumnWidths = "50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50;50"
    .IntegralHeight = False
For askm = 22 To 10000
    If Sheets("TEKNİK SERVİS").Cells(askm, 2) = Target.Value Then
        x = x + 1
        ReDim Preserve dizi(1 To 18, 1 To x)
        For i = 2 To 19
            If i = 4 Then
                dizi(i - 1, x) = Format(Sheets("TEKNİK SERVİS").Cells(askm, i).Value, "DD.MM.YYYY")
            ElseIf i = 19 Then
                dizi(i - 1, x) = VBA.FormatCurrency(Sheets("TEKNİK SERVİS").Cells(askm, i).Value, 2)
            Else
                dizi(i - 1, x) = Sheets("TEKNİK SERVİS").Cells(askm, i).Value
            End If
        Next i
    End If
Next askm
.Column = dizi
End With
End Sub

hocam ellerinize sağlık süper oldu teşekür ederim...

askm · 25 Şubat 2019

Rica ederim. Kolay gelsin.

koşullu listbox

Schuba

Ekli dosyalar

Orion1

Uzman

Ekli dosyalar

askm

Destek Ekibi

Schuba

Ekli dosyalar

askm

Destek Ekibi

Hakan ERDOST

Destek Ekibi

Ekli dosyalar

Schuba

Schuba

askm

Destek Ekibi

Schuba

Ekli dosyalar

askm

Destek Ekibi

Schuba

askm

Destek Ekibi

Schuba

askm

Destek Ekibi

Schuba

askm

Destek Ekibi