• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

süzme-listeleme

L

lodos63

Katılım
30 Kasım 2011
Mesajlar
41
Excel Vers. ve Dili
2003
merhaba arkadaşlar forumda yeniyim :) bir sorunum var yardımcı olursanız sevinirm. örnek dosyada sayfa1 de bir liste oluşturdum bu liste ne zaman , ne kadar ve kime ödeme yapıldığına dair bir liste. nasıl yapıldığını öğrenmek istediğim şey (mümkünse kod ile) sayfa 2 de bir isme ait aylık ne kadar bir ödeme yapıldığını gösterebilmek.yardımlarınızı bekliyorum.saygılar
 

Ekli dosyalar

Cevaplar bol ama istenilenin karşılığı sanırım fazlasıyla Bedri41 hocanın cevabında var. Diğer cevaplarda aylık kişilere toplam ödenen rakam görünmüyor. Ayrıca Sayfa1 deki isimlere ilave yapıldığında hocanın çözümünde bu isimler veri doğrulama kutusu içerisine otomatik geliyor.
 
arkadaşlar cevaplar için çok teşekkür ederim ama sanırım istediim şeyi tam anlamıyla ifade edememişim. Benim kastedettiğim şey bunu makro yardımıyla sayfa 2 de görebilmek bu mümkün mü acaba?
 
Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Sub benzersiz_toplama_59()
'coder:evrengizlen@hotmail.com
'date:30.11.2011
Dim sh As Worksheet, sat As Long, z As Object, liste(), myarr(), n As Long
Dim ay As String, deg As String, yil As String
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Set sh = Sheets("Sayfa2")
ay = InputBox("Lütfen Süzülecek Ay'ı Sayı Olarak Giriniz!", "AY GİRİNİZ", Month(Date))
If Not IsNumeric(ay) Then
    MsgBox "Lütfen Ayı Sayısal Olarak Giriniz!", vbCritical, "U Y A R I"
Exit Sub
    ElseIf ay = "" Then
    MsgBox "Lütfen Ay'ı Sayısal Olarak Giriniz!", vbCritical, "U Y A R I"
    Exit Sub
End If
yil = InputBox("Lütfen Süzülecek Yılı Sayı Olarak Giriniz!", "YIL GİRİNİZ", Year(Date))

If Not IsNumeric(yil) Then
    MsgBox "Lütfen Yılı Sayısal Olarak Giriniz!", vbCritical, "U Y A R I"
Exit Sub
    ElseIf yil = "" Then
    MsgBox "Lütfen Yıl'ı Sayısal Olarak Giriniz!", vbCritical, "U Y A R I"
    Exit Sub
End If


sh.Range("A2:F" & Rows.Count).ClearContents
sat = Range("A" & Rows.Count).End(xlUp).Row
If sat < 2 Then
    MsgBox "Sayfa1'de sorgulanacak veri yok!!", vbCritical, "U Y A R I"
    Application.ScreenUpdating = True
    Set sh = Nothing
    Exit Sub
End If
liste = Range("A2:F" & sat).Value
ReDim myarr(1 To 6, 1 To UBound(liste))
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(liste)
    If CLng(ay) = CLng(liste(i, 3)) And CLng(yil) = CLng(liste(i, 2)) Then
        deg = CLng(liste(i, 2)) & "-" & CLng(liste(i, 3)) & "-" & CStr(liste(i, 5))
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = liste(i, 1)
            myarr(2, n) = liste(i, 2)
            myarr(3, n) = liste(i, 3)
            myarr(4, n) = CDate(liste(i, 4))
            myarr(5, n) = liste(i, 5)
        End If
        myarr(6, z.Item(deg)) = myarr(6, z.Item(deg)) + CDbl(liste(i, 6))
    End If
Next
Erase liste
sh.Range("A2").Resize(z.Count, 6) = Application.Transpose(myarr)
Set z = Nothing
sh.Select
Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem TamamLandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub
 

Ekli dosyalar

hocam çok teşekkür ederim önceki yardımınız için... ekteki dosyada sayfa 3 de ki şekilde bir şablona, hazırladığınız formülasyonu dönüştürmek mümkünmüdür acaba?
 

Ekli dosyalar

lodos63' Alıntı:
hocam çok teşekkür ederim önceki yardımınız için... ekteki dosyada sayfa 3 de ki şekilde bir şablona, hazırladığınız formülasyonu dönüştürmek mümkünmüdür acaba?
Genişletmek için tıkla ...

Dosyayı tekrar düzelttim.
8 nolu mesajdan dosyayı indirebilirsiniz.:cool:
 
hocam inceledim fakat yanlış anlaşılma var sanırım eklediğim dosyadan sayfa3 e bakabilir misiniz?
 
lodos63' Alıntı:
hocam inceledim fakat yanlış anlaşılma var sanırım eklediğim dosyadan sayfa3 e bakabilir misiniz?
Genişletmek için tıkla ...
Dosyanız ektedir.
İlk başladıktan sonra tam 3 kez değişliklik oldu.Artık bu olur sanırım.:cool:
Dosyanız ektedir.:cool.
Kod: 
Option Base 1
Sub benzersiz_toplama_59()
'coder:evrengizlen@hotmail.com
'date:30.11.2011
Dim sh As Worksheet, sat As Long, z As Object, liste(), myarr(), n As Long
Dim ay As String, deg As String
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Set sh = Sheets("Sayfa2")
ay = InputBox("Lütfen Süzülecek Ay'ı Sayı Olarak Giriniz!", "AY GİRİNİZ", Month(Date))
If Not IsNumeric(ay) Then
    MsgBox "Lütfen Ayı Sayısal Olarak Giriniz!", vbCritical, "U Y A R I"
Exit Sub
    ElseIf ay = "" Then
    MsgBox "Lütfen Ay'ı Sayısal Olarak Giriniz!", vbCritical, "U Y A R I"
    Exit Sub
End If
sh.Range("A2:F" & Rows.Count).ClearContents
sat = Range("A" & Rows.Count).End(xlUp).Row
If sat < 2 Then
    MsgBox "Sayfa1'de sorgulanacak veri yok!!", vbCritical, "U Y A R I"
    Application.ScreenUpdating = True
    Set sh = Nothing
    Exit Sub
End If
liste = Range("A2:F" & sat).Value
ReDim myarr(1 To 6, 1 To UBound(liste))
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(liste)
    If ay = liste(i, 3) Then
        deg = CLng(liste(i, 3)) & "-" & CStr(liste(i, 5))
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = liste(i, 1)
            myarr(2, n) = liste(i, 2)
            myarr(3, n) = liste(i, 3)
            myarr(4, n) = CDate(liste(i, 4))
            myarr(5, n) = liste(i, 5)
        End If
        myarr(6, z.Item(deg)) = myarr(6, z.Item(deg)) + CDbl(liste(i, 6))
    End If
Next
Erase liste
sh.Range("A2").Resize(z.Count, 6) = Application.Transpose(myarr)
Set z = Nothing
sh.Select
Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem TamamLandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub
 

Ekli dosyalar

hocam ilgilendiğiniz için teşekkür ederim ama son gönderdiğiniz dosyada ben bi farklılık göremedim sayfa 3 de ki şablona uygun bir yapı değil sanırım. önceki hazırladığınız sayfa2 deki şekilde çalışıyor. Benim bu çalışada amacım bir kişiye ait ay ay kaç TL ödeme yapıldığını görmek.
 
lodos63' Alıntı:
hocam ilgilendiğiniz için teşekkür ederim ama son gönderdiğiniz dosyada ben bi farklılık göremedim sayfa 3 de ki şablona uygun bir yapı değil sanırım. önceki hazırladığınız sayfa2 deki şekilde çalışıyor. Benim bu çalışada amacım bir kişiye ait ay ay kaç TL ödeme yapıldığını görmek.
Genişletmek için tıkla ...
Ben sayfa3'te bir şey yazmadım.Sayfa2 'de bir kişiye ait değerleri yazdım.
Net açıklama olmayınca böyle oluyor işte.
 
Ekli dosya oldu sanırım.:cool:
Kod: 
Option Base 1
Sub benzersiz_toplama_59()
'coder:evrengizlen@hotmail.com
'date:30.11.2011
Dim sh As Worksheet, sat As Long, z As Object, liste(), myarr(), n As Long
Dim ay As String, deg As String, yil As String
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Set sh = Sheets("Sayfa2")
ay = InputBox("Lütfen Süzülecek Ay'ı Sayı Olarak Giriniz!", "AY GİRİNİZ", Month(Date))
If Not IsNumeric(ay) Then
    MsgBox "Lütfen Ayı Sayısal Olarak Giriniz!", vbCritical, "U Y A R I"
Exit Sub
    ElseIf ay = "" Then
    MsgBox "Lütfen Ay'ı Sayısal Olarak Giriniz!", vbCritical, "U Y A R I"
    Exit Sub
End If
yil = InputBox("Lütfen Süzülecek Yılı Sayı Olarak Giriniz!", "YIL GİRİNİZ", Year(Date))

If Not IsNumeric(yil) Then
    MsgBox "Lütfen Yılı Sayısal Olarak Giriniz!", vbCritical, "U Y A R I"
Exit Sub
    ElseIf yil = "" Then
    MsgBox "Lütfen Yıl'ı Sayısal Olarak Giriniz!", vbCritical, "U Y A R I"
    Exit Sub
End If

sh.Range("A2:F" & Rows.Count).ClearContents
Sheets("Sayfa3").Range("A2:R" & Rows.Count).ClearContents
sat = Range("A" & Rows.Count).End(xlUp).Row
If sat < 2 Then
    MsgBox "Sayfa1'de sorgulanacak veri yok!!", vbCritical, "U Y A R I"
    Application.ScreenUpdating = True
    Set sh = Nothing
    Exit Sub
End If
liste = Range("A2:F" & sat).Value
ReDim myarr(1 To 19, 1 To UBound(liste))
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(liste)
    If CLng(ay) = CLng(liste(i, 3)) And CLng(yil) = CLng(liste(i, 2)) Then
        deg = CLng(liste(i, 2)) & "-" & CLng(liste(i, 3)) & "-" & liste(i, 5)
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = liste(i, 1)
            myarr(2, n) = liste(i, 2)
            myarr(3, n) = liste(i, 3)
            myarr(4, n) = CDate(liste(i, 4))
            myarr(5, n) = liste(i, 5)
        End If
        myarr(6, z.Item(deg)) = myarr(6, z.Item(deg)) + CDbl(liste(i, 6))
        myarr(6 + CLng(ay), z.Item(deg)) = myarr(6 + CLng(ay), z.Item(deg)) + CDbl(liste(i, 6))
    End If
Next
Erase liste
If z.Count > 0 Then
    sh.Range("A2").Resize(z.Count, 6) = Application.Transpose(myarr)
    Sheets("Sayfa3").Range("A2").Resize(z.Count, 19) = Application.Transpose(myarr)
End If
Set z = Nothing
Erase myarr
Sheets("Sayfa3").Select
Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem TamamLandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub
 

Ekli dosyalar

hocam teşekkürler yardımlarınız için ben açıkladığımı düşündüm sizde ek bilgi istemeyince sanırım iş uzadı birazcık. Asıl yapılması gereken şu idi makro aktif olduktan sonra sayfa 3 te kim hangi ay ne kadar almışlarsa yansımalarıydı. Bu nedenle en başta zaten bi ay seçmeye gerek yoktu. Şu anki haliyle sadece ilgili ay hangisi seçiliyorsa o kısımlar süzülüyor ve sayfada ilgili ayın olduğu sütuna yansıyor diğer aylar boş kalıyor. Boş kalması ancak ilgili kişilere o ay ödeme yapılmadığı durumda lması gerekiyordu. ben çok vaktinizi aldım sanırım istemeden hakkınızı helal edin lütfen..
 
lodos63' Alıntı:
hocam teşekkürler yardımlarınız için ben açıkladığımı düşündüm sizde ek bilgi istemeyince sanırım iş uzadı birazcık. Asıl yapılması gereken şu idi makro aktif olduktan sonra sayfa 3 te kim hangi ay ne kadar almışlarsa yansımalarıydı. Bu nedenle en başta zaten bi ay seçmeye gerek yoktu. Şu anki haliyle sadece ilgili ay hangisi seçiliyorsa o kısımlar süzülüyor ve sayfada ilgili ayın olduğu sütuna yansıyor diğer aylar boş kalıyor. Boş kalması ancak ilgili kişilere o ay ödeme yapılmadığı durumda lması gerekiyordu. ben çok vaktinizi aldım sanırım istemeden hakkınızı helal edin lütfen..
Genişletmek için tıkla ...
Dosyanız ektedir.:cool:
Kod: 
Option Base 1
Sub benzersiz_toplama_59()
'coder:evrengizlen@hotmail.com
'date:30.11.2011
Dim sh As Worksheet, sat As Long, z As Object, liste(), myarr(), n As Long
Dim ay As String, deg As String, yil As String
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Set sh = Sheets("Sayfa3")
yil = InputBox("Lütfen Süzülecek Yılı Sayı Olarak Giriniz!", "YIL GİRİNİZ", Year(Date))

If Not IsNumeric(yil) Then
    MsgBox "Lütfen Yılı Sayısal Olarak Giriniz!", vbCritical, "U Y A R I"
Exit Sub
    ElseIf yil = "" Then
    MsgBox "Lütfen Yıl'ı Sayısal Olarak Giriniz!", vbCritical, "U Y A R I"
    Exit Sub
End If

sh.Range("A2:R" & Rows.Count).ClearContents
sat = Range("A" & Rows.Count).End(xlUp).Row
If sat < 2 Then
    MsgBox "Sayfa1'de sorgulanacak veri yok!!", vbCritical, "U Y A R I"
    Application.ScreenUpdating = True
    Set sh = Nothing
    Exit Sub
End If
liste = Range("A2:F" & sat).Value
ReDim myarr(1 To 19, 1 To UBound(liste))
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(liste)
    If CLng(yil) = CLng(liste(i, 2)) Then
        deg = CLng(liste(i, 2)) & "-" & CInt(liste(i, 3)) & liste(i, 5)
        If Not z.exists(deg) Then
            n = n + 1
            z.Add deg, n
            myarr(1, n) = liste(i, 1)
            myarr(2, n) = liste(i, 2)
            myarr(3, n) = liste(i, 3)
            myarr(4, n) = CDate(liste(i, 4))
            myarr(5, n) = liste(i, 5)
        End If
        myarr(6, z.Item(deg)) = myarr(6, z.Item(deg)) + CDbl(liste(i, 6))
        myarr(6 + CInt(liste(i, 3)), z.Item(deg)) = myarr(6 + CInt(liste(i, 3)), z.Item(deg)) + CDbl(liste(i, 6))
    End If
Next
Erase liste
If z.Count > 0 Then
    sh.Range("A2").Resize(z.Count, 19) = Application.Transpose(myarr)
End If
Set z = Nothing
Erase myarr
Sheets("Sayfa3").Select
Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem TamamLandı." & vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, Application.UserName
End Sub
 

Ekli dosyalar

hocam iki gündür sizi uğraştırıyorum fakat maalesef çıkar yol bulamadım... eğer sabrınızı çok zorlamayacaksa ve vaktiniz varsa örnek dosyada yapılması gereken şu: sayfa1 de ki liste sayfa 3 de süzülecek. en başta belki sadece yıl seçimi yapılabilir. sayfa 3 te zaten ay ay bir kişiye ait toplam ödeme miktarı mevcut. ilgili kişiye aylık ne kadar ise o ay başlıklık sütuna yansıtılması gerekiyor. ben artık bu işin bittikten sonraki halindense kod olarak nasıl olduğu merak ediyorum gerçekten. luşturulacak bu yapıyı bir kaç form da kullanmam gerekiyor.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst