Tek Hücre değerine göre listeleme

[Turgay KARAŞAH]

Değerli üstatlarım; Sorun; A1 hücresine yazdığım SEMT/İLÇE değerine göre (BAĞLAMA KÜTÜĞÜ sayfasının
P sütunundaki SEMT /İLÇE bilgisidir) BAĞLAMA KÜTÜĞÜ sayfasındaki bu kritere uyan SEMT/İLÇE bilgilerinin
alt alta sıralanmasını istiyorum. (Galiba CTRL+SHIFT+ENTER kullanamıyorum)

 

[Turgay KARAŞAH]

Emek verecek arkadaşlara şimdiden teşekkürler.

 

[YUSUF44]

Bu kadar büyük listelerde formülle işlem yapılması tavsiye edilmez, hem yavaş olur hem de bilgisayarı zorlar. SQL listeleme yöntemiyle çok daha hızlı sonuç alabilirsiniz. Bunun için öncelikle sayfanızdaki tüm formülleri silin. Aşağıdaki kodları LİSTELE sayfasının kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) kopyalayın. A1 hücresini değiştirdiğinizde istediğiniz listelemeyi yapacaktır:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1]) Is Nothing Then Exit Sub
Set s1 = Sheets("BAĞLAMA KÜTÜĞÜ")
eski = WorksheetFunction.Max(3, Cells(Rows.Count, "P").End(3).Row)
son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "P").End(3).Row)

If Selection.Count > 1 Then Exit Sub

If Target = "" Then
    Range("A3:X" & son).ClearContents
    Target.Select
ElseIf WorksheetFunction.CountIf(s1.Range("P1:P" & son), Target) = 0 Then
    Range("A3:X" & son).ClearContents
    MsgBox "Bağlama Kütüğü sayfasıdna aranan semt/ilçe bulunamadı", vbCritical
    Target.Select
    Exit Sub
Else
    Set con = VBA.CreateObject("adodb.Connection")
    
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=NO"""
    
    sorgu = "select F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12,F13,F14,F15,F16,F17,F18,F19,F20,F21,F22,F23,F24 " & _
      "from[BAĞLAMA KÜTÜĞÜ$] where F16 = '" & Target & "'"
      
    Set rs = con.Execute(sorgu)
    Range("A3").CopyFromRecordset rs
End If
End Sub

 

[YUSUF44]

Yalnız anladığım kadarıyla dosyanızda gerçek veriler var. Bunları değiştirmenizi ve dosyayı paylaşımdan kaldırmanızı tavsiye ederim.

 

[Turgay KARAŞAH]

Yusuf bey zahmet verdim fakat çalışmadı. Kodu kopyala yapıştır yaptım olmadı.

 

[YUSUF44]

Dosyayı o şekilde paylaşır mısınız? (Tabi gerçek bilgiler olmasın)

 

[Turgay KARAŞAH]

dosya ektedir. Teşekkürler

 

[YUSUF44]

Bu dosya ile ilk dosyanız, bu dosyadaki taleple ilk dosyanızdaki talebiniz aynı değil maalesef. Dosyanızda verdiğim kod yok, formüller duruyor. İlk dosyanızda sayfa adı BAĞLAMA KÜTÜĞÜ iken şimdi BAGLAMA KÜTÜGÜ. Ben verdiğim çözümün çalışmadığı halini görmek istemiştim.

Son dosyanıza göre olması gereken kod aşağıdaki gibidir. Kodu bir önceki mesajımda belirttiğim şekilde sayfanın kod bölümüne ekleyin lütfen:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B5, D5]) Is Nothing Then Exit Sub
Set s1 = Sheets("BAGLAMA KÜTÜGÜ")
son = WorksheetFunction.Max(7, s1.Cells(Rows.Count, "I").End(3).Row, s1.Cells(Rows.Count, "P").End(3).Row)

If Selection.Count > 1 Then Exit Sub

If Target = "" Then
    Range("A9:Y" & Rows.Count).ClearContents
    Target.Select
ElseIf WorksheetFunction.CountIf(s1.Range("P1:P" & son), [B5]) = 0 Then
    Range("A9:Y" & Rows.Count).ClearContents
    MsgBox "Bağlama Kütüğü sayfasında aranan semt/ilçe bulunamadı", vbCritical
    [B5].Select
    Exit Sub
ElseIf WorksheetFunction.CountIf(s1.Range("I1:I" & son), [D5]) = 0 Then
    Range("A9:Y" & Rows.Count).ClearContents
    MsgBox "Bağlama Kütüğü sayfasında aranan gemi cinsi bulunamadı", vbCritical
    [D5].Select
    Exit Sub
ElseIf [B5] = "" Or [D5] = "" Then
    Exit Sub
Else
    Range("A9:Y" & Rows.Count).ClearContents
    Set con = VBA.CreateObject("adodb.Connection")
    
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=NO"""
    
    sorgu = "select F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12,F13,F14,F15,F16,F17,F18,F19,F20,F21,F22,F23,F24,F25 " & _
      "from[BAGLAMA KÜTÜGÜ$] where F16 = '" & [B5] & "' and F9 = '" & [D5] & "'"
      
    Set rs = con.Execute(sorgu)
    Range("A9").CopyFromRecordset rs
    liste = Cells(Rows.Count, "A").End(3).Row - 8
    [E5] = liste
    MsgBox [B5] & " semt/ilçesine ait " & liste & " adet " & [D5] & " listelendi."
End If
End Sub

 

[Turgay KARAŞAH]

Üstad yusuf44; yanlışlıkla ilk çalışmayı atmışım, uğraştırdım özür dilerim. Mesajımın ilk LİSTE dosyasını veriler silinmiş ve ilk kodunuz yüklenmiş olarak tekrar attım. Saygılar

 

[YUSUF44]

İlk satırı kopyalamadığınızın farkında mısınız

Kodda küçük bir düzeltme yaptım, aşağıdaki kodun tümünü kullanın:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1]) Is Nothing Then Exit Sub
Set s1 = Sheets("BAĞLAMA KÜTÜĞÜ")
eski = WorksheetFunction.Max(3, Cells(Rows.Count, "P").End(3).Row)
son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "P").End(3).Row)

If Selection.Count > 1 Then Exit Sub

If Target = "" Then
    Range("A3:X" & eski).ClearContents
    Target.Select
ElseIf WorksheetFunction.CountIf(s1.Range("P1:P" & son), Target) = 0 Then
    Range("A3:X" & eski).ClearContents
    MsgBox "Bağlama Kütüğü sayfasıdna aranan semt/ilçe bulunamadı", vbCritical
    Target.Select
    Exit Sub
Else
    Range("A3:X" & eski).ClearContents
    Set con = VBA.CreateObject("adodb.Connection")
    
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=NO"""
    
    sorgu = "select F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12,F13,F14,F15,F16,F17,F18,F19,F20,F21,F22,F23,F24 " & _
      "from[BAĞLAMA KÜTÜĞÜ$] where F16 = '" & Target & "'"
      
    Set rs = con.Execute(sorgu)
    Range("A3").CopyFromRecordset rs
End If
End Sub

 

[Turgay KARAŞAH]

İşlem tamam. Şahsen bir MALATYA eniştesi olarak sizi dünden beri uğraştırdım hakkınızı helal edin. İnanın siz ve sizin gibi bu işe gönül vermiş üstatlarımla tanışınca imreniyor ve sizlerle gurur duyuyorum. ALLAH SİZ VE SİZİNGİBİLERDEN RAZI OLSUN. SONSUZ TEŞEKKÜRLER.

 

[YUSUF44]

Estağfurullah. Bu vesileyle bundan sonraki sorularınızda daha dikkatli olursunuz

Selam ve saygılar, iyi çalışmalar.