Arama ile birden fazla sonuç

[kağızman]

Merhabalar,

kasa hesap takibi için kullandığım programda tek sayfa üzerinden kayıtlarımı tutuyordum ve filtre ile istediğim kişinin hareketlerini ayrıca görebiliyordum. Fakat kişi sayısı arttııkça filtre özelliği uğraştırmaya başladı. Şimdi ise 2. sayfada A1 hücresine yazdığım kişinin hareketlerinin listelenmesi için uğraşıyorum. Düşeyara fonksiyonuyla işin içinden çıkamadım. Yardımlarınız için şimdiden teşekkür ederim.

 

[İhsan Tank]

Merhabalar,

kasa hesap takibi için kullandığım programda tek sayfa üzerinden kayıtlarımı tutuyordum ve filtre ile istediğim kişinin hareketlerini ayrıca görebiliyordum. Fakat kişi sayısı arttııkça filtre özelliği uğraştırmaya başladı. Şimdi ise 2. sayfada A1 hücresine yazdığım kişinin hareketlerinin listelenmesi için uğraşıyorum. Düşeyara fonksiyonuyla işin içinden çıkamadım. Yardımlarınız için şimdiden teşekkür ederim.

merhaba
eki inceler misiniz

 

[kağızman]

merhaba
eki inceler misiniz

Hocam çok teşekkürler..

Tamamen benim istediğimi yapmışsınız. Şu dizi olayını çözmem lazım.
Bir de bu durumda kayıtların listelenmesi çok zaman alıyor.
Acaba her şahıs için ayrı sayfa açsam (sayfalara şahıs ismi vererek) anasayfada yaptığım değişikliği yansıtma olayı nasıl olur ? tekrar yardımcı olabilir misiniz ?

 

[Orion1]

Dosyanzız ektedir.

Option Base 1
Sub aktar()
Dim s1 As Worksheet, sat As Long, list(), myarr()
Dim z As Object, deg As String, i As Long, n As Long, isim As String
Set s1 = Sheets("Sayfa1")
sat = s1.Cells(65536, "A").End(xlUp).Row
Range("A3:D65536").ClearContents
If sat < 4 Or Range("A1").Value = "" Then Exit Sub
Application.ScreenUpdating = False
list = s1.Range("A4:D" & sat).Value
Set z = CreateObject("scripting.dictionary")
ReDim myarr(1 To 4, 1 To sat)
isim = UCase(Replace(Replace(Range("A1").Value, "i", "İ"), "ı", "I"))
For i = 1 To UBound(list, 1)
    If UCase(Replace(Replace(list(i, 2), "i", "İ"), "ı", "I")) = isim Then
        deg = list(i, 1) & isim
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = list(i, 1)
            myarr(2, n) = list(i, 2)
        End If
        myarr(3, z.Item(deg)) = myarr(3, z.Item(deg)) + list(i, 3)
        myarr(4, z.Item(deg)) = myarr(4, z.Item(deg)) + list(i, 4)
    End If
Next i
Set z = Nothing
Range("A3").Resize(n, 4) = Application.Transpose(myarr)
Erase myarr
Application.ScreenUpdating = True

End Sub

 

[kağızman]

Dosyanzız ektedir.

elinize sağlık teşekkür ederim

 

[Orion1]

elinize sağlık teşekkür ederim

Rica ederim
İyi çalışmalar.