Excel Filtreleme

[gkhnn2]

Merhaba,

Bugün bir konu sormuştum aşağıda linkini paylaşıyorum.

Filtreleme Konusuda Yardım

Merhaba, Muhasebe kontrol işlemlerini kolaylaştırmak adına eğer zahmet olmazsa yardım talebinde bulunacağım. Ekteki dosyadaki excelde Veri ve Sonuç adında sekmeler mevcut, veri alanını kopyala yapıştır ile dolduracağım sizden talebim; Sonuç sekmesinde Turuncu b2 hücresine Veri alanındaki Fiş...

www.excel.web.tr

Affınıza sığınarak tekrar bir istekte bulunmak istiyorum,

önceki sorumdaki aynı veriler için başka bir varyasyon yapmak istiyorum, aynı excel dosyası içesisinde olabilir mi bilmedim.(Aynı anda ikiside çalışsın(farklı sekmelerde))

Bu kez hesap kodu ile arama yapmak ve aynı fişteki karşı hesaplarında gelmesini istiyorum (aynı fişten kastım aynı fiş numarasına sahip satırlardır)

Örn. arama alanına 100 yazdığımda sonuç2(diğeri sonuçtu) sayfasına hem veri alanındaki 100 hesaplarının bulunduğu tüm satır gelsin hem de 100 hesabının evrak numarasına bakıp içerisinde 100 hesap olan fişlere ait tüm satırları da yazsın.

 

[gkhnn2]

mümkün bir olay değil sanırım?

 

[Korhan Ayhan]

A5 hücresine uygulayınız. Yana ve alt hücrelere biçimleri bozmamak için formül olarak yapıştırırsınız.

DİZİ formüldür. Formülü hücreye uyguladıktan sonra hücreyi CTRL+SHIFT+ENTER tuşlarına basarak terk ediniz. Aksi durumda doğru sonuç vermez.

=EĞERHATA(İNDİS(Veri!$A$2:$H$10000;KÜÇÜK(EĞER((Veri!$C$2:$C$10000=$B$2)+(Veri!$E$2:$E$10000=$B$2);SATIR(Veri!$A$2:$A$10000)-1);SATIR($A1));SÜTUN());"")

 

[gkhnn2]

Yapamadığım/ atladığım bir yer var sanırım. sonuç sekmesinde a2'ye yapıştırıyorum ama sonuç vermiyor.

 

[Korhan Ayhan]

Formülün başına eşittir ekleyin ve DİZİ formül olarak uygulayın.

 

[gkhnn2]

Korhan Bey,

formül çalıştı, Turuncu alana hesap kodunu yazdığımda alta o hesabın bulunduğu satırları getiriyor fakat benim isteğim biraz daha farklıydı.

arama alanına 100 yazdığımda hem sizin yaptığınız gibi 100 hesap kodu içeren satırları getirsin hemde 100 hesap kodu içeren satırın fiş numarasına bakıp o fişte kaç satır varsa onları da getirsin.

Örneğin, Veri tablomda 50 ayrı satırda 100 hesap var bana o 50 satırı versin ayrıca alta o satırların fiş numaralarına bakıp o fiş numaralarında kaç adet satır varsa onları da yazsın.(Bu dediğim sistemde aynı sayfada çok fazla formul olacağından excelde şişme olacaktır tahminim bu sistemi makro ile çalıştırmak mümkün olur mu?)

 

[Korhan Ayhan]

Örnek dosya üzerinde tarif ederseniz yardım etmemiz kolaylaşır.

 

[YUSUF44]

Sonuç sayfasını kopyalayın.

Aşağıdaki kodları bu yeni sayfanın kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) kopyalayın. B2'de hesap kodu yazdığınızda istediğiniz listelemeyi yapar:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2]) Is Nothing Then Exit Sub
Set s1 = Sheets("Veri")
eski = WorksheetFunction.Max(5, Cells(Rows.Count, "A").End(3).Row)
son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
If Target = "" Then
    Range("A5:H" & eski).ClearContents
ElseIf WorksheetFunction.CountIf(s1.Range("C1:C" & son), Target) = 0 Then
    Range("A5:H" & eski).ClearContents
    MsgBox "Girilen hesap koduna ait herhangi bir kayıt bulunmamaktadır!", vbInformation
    Exit Sub
Else
    Range("A5:H" & 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=yes"""
   
    sorgu = "select Tarih,[Fiş No],[Hesap Kodu],[Evrak Türü],[Evrak No],Açıklama,Borç,Alacak " & _
      "from[Veri$] where [Hesap Kodu]=" & Target
     
    Set rs = con.Execute(sorgu)
    [A5].CopyFromRecordset rs
   
    say = Cells(Rows.Count, "A").End(3).Row
    For i = 5 To say
        sorgu = "select Tarih,[Fiş No],[Hesap Kodu],[Evrak Türü],[Evrak No],Açıklama,Borç,Alacak " & _
          "from[Veri$] where [Fiş No]=" & Cells(i, "B")
         
        Set rs = con.Execute(sorgu)
        yeni = Cells(Rows.Count, "A").End(3).Row + 1
        Cells(yeni, "A").CopyFromRecordset rs
    Next
End If

End Sub

 

[gkhnn2]

Sonuç sayfasını kopyalayın.

Aşağıdaki kodları bu yeni sayfanın kod bölümüne (sayfa adına sağ tıklayıp kod görüntüle deyince açılan sayfaya) kopyalayın. B2'de hesap kodu yazdığınızda istediğiniz listelemeyi yapar:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2]) Is Nothing Then Exit Sub
Set s1 = Sheets("Veri")
eski = WorksheetFunction.Max(5, Cells(Rows.Count, "A").End(3).Row)
son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
If Target = "" Then
    Range("A5:H" & eski).ClearContents
ElseIf WorksheetFunction.CountIf(s1.Range("C1:C" & son), Target) = 0 Then
    Range("A5:H" & eski).ClearContents
    MsgBox "Girilen hesap koduna ait herhangi bir kayıt bulunmamaktadır!", vbInformation
    Exit Sub
Else
    Range("A5:H" & 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=yes"""
  
    sorgu = "select Tarih,[Fiş No],[Hesap Kodu],[Evrak Türü],[Evrak No],Açıklama,Borç,Alacak " & _
      "from[Veri$] where [Hesap Kodu]=" & Target
    
    Set rs = con.Execute(sorgu)
    [A5].CopyFromRecordset rs
  
    say = Cells(Rows.Count, "A").End(3).Row
    For i = 5 To say
        sorgu = "select Tarih,[Fiş No],[Hesap Kodu],[Evrak Türü],[Evrak No],Açıklama,Borç,Alacak " & _
          "from[Veri$] where [Fiş No]=" & Cells(i, "B")
        
        Set rs = con.Execute(sorgu)
        yeni = Cells(Rows.Count, "A").End(3).Row + 1
        Cells(yeni, "A").CopyFromRecordset rs
    Next
End If

End Sub

Evet istediğim tam olarak buydu, fakat bir sorun var şuan aradığım kod aşağıdaki listede 2 sefer yazıyor. (her bulduğu 100 hesap içeren satırı yazıyor devamında bulduğu hesabı tekrar yazarak alt satırlara devam ediyor.

Örn. arama satırına 100 yazdığımda aşağıdaki gibi yazıyor.

100 XX
100 XX
191 XX
770 XX

 

[YUSUF44]

E siz öyle istemiştiniz. "Önce 100 olanları listelesin, sonra da 100'ün fiş nosu neyse o fiş kodunu listelesin" istememiş miydiniz?

 

[gkhnn2]

E siz öyle istemiştiniz. "Önce 100 olanları listelesin, sonra da 100'ün fiş nosu neyse o fiş kodunu listelesin" istememiş miydiniz?

Yanlış ifade ettim sanırım, Önce 100 olanları listelesin, sonra da 100'ün fiş nosu neyse 100 satırı hariç kalanları listelesin.

 

[YUSUF44]

Aşağıdaki gibi deneyin:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2]) Is Nothing Then Exit Sub
Set s1 = Sheets("Veri")
eski = WorksheetFunction.Max(5, Cells(Rows.Count, "A").End(3).Row)
son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
If Target = "" Then
    Range("A5:H" & eski).ClearContents
ElseIf WorksheetFunction.CountIf(s1.Range("C1:C" & son), Target) = 0 Then
    Range("A5:H" & eski).ClearContents
    MsgBox "Girilen hesap koduna ait herhangi bir kayıt bulunmamaktadır!", vbInformation
    Exit Sub
Else
    Range("A5:H" & 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=yes"""
  
    sorgu = "select Tarih,[Fiş No],[Hesap Kodu],[Evrak Türü],[Evrak No],Açıklama,Borç,Alacak " & _
      "from[Veri$] where [Hesap Kodu]=" & Target
    
    Set rs = con.Execute(sorgu)
    [A5].CopyFromRecordset rs
  
    say = Cells(Rows.Count, "A").End(3).Row
    For i = 5 To say
        sorgu = "select Tarih,[Fiş No],[Hesap Kodu],[Evrak Türü],[Evrak No],Açıklama,Borç,Alacak " & _
          "from[Veri$] where [Fiş No]=" & Cells(i, "B")
        
        Set rs = con.Execute(sorgu)
        yeni = Cells(Rows.Count, "A").End(3).Row + 1
        Cells(yeni, "A").CopyFromRecordset rs
    Next
End If
enson = Cells(Rows.Count, "A").End(3).Row
Range("A4:H" & enson).RemoveDuplicates Columns:=Array(2, 3), Header:=xlYes
End Sub

 

[gkhnn2]

Aşağıdaki gibi deneyin:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [B2]) Is Nothing Then Exit Sub
Set s1 = Sheets("Veri")
eski = WorksheetFunction.Max(5, Cells(Rows.Count, "A").End(3).Row)
son = WorksheetFunction.Max(2, s1.Cells(Rows.Count, "A").End(3).Row)
If Target = "" Then
    Range("A5:H" & eski).ClearContents
ElseIf WorksheetFunction.CountIf(s1.Range("C1:C" & son), Target) = 0 Then
    Range("A5:H" & eski).ClearContents
    MsgBox "Girilen hesap koduna ait herhangi bir kayıt bulunmamaktadır!", vbInformation
    Exit Sub
Else
    Range("A5:H" & 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=yes"""
 
    sorgu = "select Tarih,[Fiş No],[Hesap Kodu],[Evrak Türü],[Evrak No],Açıklama,Borç,Alacak " & _
      "from[Veri$] where [Hesap Kodu]=" & Target
   
    Set rs = con.Execute(sorgu)
    [A5].CopyFromRecordset rs
 
    say = Cells(Rows.Count, "A").End(3).Row
    For i = 5 To say
        sorgu = "select Tarih,[Fiş No],[Hesap Kodu],[Evrak Türü],[Evrak No],Açıklama,Borç,Alacak " & _
          "from[Veri$] where [Fiş No]=" & Cells(i, "B")
       
        Set rs = con.Execute(sorgu)
        yeni = Cells(Rows.Count, "A").End(3).Row + 1
        Cells(yeni, "A").CopyFromRecordset rs
    Next
End If
enson = Cells(Rows.Count, "A").End(3).Row
Range("A4:H" & enson).RemoveDuplicates Columns:=Array(2, 3), Header:=xlYes
End Sub

Çok teşekkürler, şuan tam olarak istediğim gibi oldu ellerinize sağlık.

Arama alanına farklı karakterler girebiliyor muyuz? (. , / - veya harf gibi) ayrıca karakter giriş üst limiti var mı? (Farkındayım bazı detayları atlamışım benim oraya yazacağım hesap kodları genelde 100.10.001 veya 100 10 001 gibi olabiliyor.)

 

[Korhan Ayhan]

Size çözüm önerilmiş. Denemekten zarar gelmez.