• DİKKAT

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

Çoklu kriterlere göre benzersizleri listeleyip toplamak

  • Konbuyu başlatan Konbuyu başlatan bebar
  • Başlangıç tarihi Başlangıç tarihi
B

bebar

Katılım
12 Kasım 2014
Mesajlar
255
Excel Vers. ve Dili
2013
Merhaba,
Listboxa benzersiz değerleri alabiliyorum fakat
2 koşulu olan benzersizleri alıp toplayamıyorum.
Ekte belirttiğim dosyada belirttiğim gibi
2 kritere göre bezersizleri listeleyip toplamlarını almak istiyorum
yardımcı olursanız memnun olurum.
 

Ekli dosyalar

Benzer bir örnek dosyada paylaşırsanız, revize edip kendime uyarlayabilirim.
Çok bakındım ama bulamadım
 
Kardeşim beni yanlış anladın bahsettiğim formül değil
teşekkür ederim.
 
Buyurun.:cool:
Kod: 
Sub benzersiz_59()
Dim z As Object, sonsat As Long, i As Long, deg As String
Set z = CreateObject("scripting.dictionary")
sonsat = Cells(Rows.Count, "B").End(xlUp).Row
For i = 4 To sonsat
    deg = Cells(i, "B").Value & "        " & Cells(i, "D").Value
    If Not z.exists(deg) Then
        z.Add deg, Cells(i, "H").Value
    Else
        z.Item(deg) = z.Item(deg) + Cells(i, "H").Value
    End If
Next i
Sayfa1.ListBox1.List = Application.Transpose(Array(z.keys, z.items))
Set z = Nothing
End Sub
 
hocam çok olmazsam bir sorum daha olacak
bir texbox ım var oraya girdiğim değerri d sütununda içerenleri bulup sonra toplatabilirmiyim.
 
Textbox nerede,userformdamı , sayfadamı? :cool:
 
Orion1' Alıntı:
Buyurun.:cool:
Kod: 
Sub benzersiz_59()
Dim z As Object, sonsat As Long, i As Long, deg As String
Set z = CreateObject("scripting.dictionary")
sonsat = Cells(Rows.Count, "B").End(xlUp).Row
For i = 4 To sonsat
    deg = Cells(i, "B").Value & "        " & Cells(i, "D").Value
    If Not z.exists(deg) Then
        z.Add deg, Cells(i, "H").Value
    Else
        z.Item(deg) = z.Item(deg) + Cells(i, "H").Value
    End If
Next i
Sayfa1.ListBox1.List = Application.Transpose(Array(z.keys, z.items))
Set z = Nothing
End Sub
Genişletmek için tıkla ...



Hocam vermiş olduğunuz kodlarla kendime aşağıdaki gibi kod oluşturdum. çalışıyor ama bahsettiğim gibi aynı zamanda texbox3 e girdiğim veriyi D sütununda arayıp girdiğim veriyi içerenleri filtrelemseini istiyorum.
ilginiz için teşekkür ederim.

Kod: 
    Dim S1 As Worksheet, S2 As ListBox, s3 As TextBox, Zaman As Double
    Dim X As Long, Son As Long, Veri As Variant, Say As Long
    Zaman = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   ListBox4.Clear
    Set S1 = Sheets("Sayfa1")

    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A12:p" & Son)

    ReDim Liste(1 To UBound(Veri, 1), 1 To 9)
    For X = 1 To UBound(Veri, 1)

        Kriter = Veri(X, 3) & "#" & Veri(X, 5)
        If Not Dizi.exists(Kriter) Then
            
            Say = Say + 1
            Dizi.Add Kriter, Say
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Veri(X, 2)
            Liste(Say, 3) = Veri(X, 3)
            Liste(Say, 4) = Veri(X, 4)
            Liste(Say, 5) = Veri(X, 5)
            Liste(Say, 6) = Veri(X, 6)
            Liste(Say, 7) = Veri(X, 16)
            
            
        End If
        Liste(Dizi.Item(Kriter), 8) = Liste(Dizi.Item(Kriter), 8) + Veri(X, 12)
        Liste(Dizi.Item(Kriter), 9) = Liste(Dizi.Item(Kriter), 9) + Veri(X, 13)
    
    Next
    ListBox4.List = Liste
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
 
Döngü bölümünü aşağıdaki gibi revize edip deneyiniz.

Kod: 
    For X = 1 To UBound(Veri, 1)
        If Veri(X, 4) Like "*" & TextBox3 & "*" Then
        Kriter = Veri(X, 3) & "#" & Veri(X, 5)
        If Not Dizi.exists(Kriter) Then
            
            Say = Say + 1
            Dizi.Add Kriter, Say
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Veri(X, 2)
            Liste(Say, 3) = Veri(X, 3)
            Liste(Say, 4) = Veri(X, 4)
            Liste(Say, 5) = Veri(X, 5)
            Liste(Say, 6) = Veri(X, 6)
            Liste(Say, 7) = Veri(X, 16)
            
            
        End If
        Liste(Dizi.Item(Kriter), 8) = Liste(Dizi.Item(Kriter), 8) + Veri(X, 12)
        Liste(Dizi.Item(Kriter), 9) = Liste(Dizi.Item(Kriter), 9) + Veri(X, 13)
        End If
    Next
 
bebar' Alıntı:
userform
textbox3
listboxımda userformda
Genişletmek için tıkla ...
Deneyiniz.:cool:
Kod: 
Private Sub TextBox3_Change()
Dim z As Object, sonsat As Long, i As Long, deg As String
Set z = CreateObject("scripting.dictionary")
sonsat = Cells(Rows.Count, "D").End(xlUp).Row
For i = 4 To sonsat
    If Cells(i, "D").Value Like "*" & TextBox3.Value & "*" Then
        deg = Cells(i, "D").Value
        If Not z.exists(deg) Then
            z.Add deg, Cells(i, "H").Value
        Else
            z.Item(deg) = z.Item(deg) + Cells(i, "H").Value
        End If
    End If
Next i
Me.ListBox1.List = Application.Transpose(Array(z.keys, z.items))
Set z = Nothing
End Sub
 
hocam yapamadım.
aşağıdaki gibi kod oluşturdum.
hem bezersiz gerip toplayıp hemde süzmek istedim fakat hata alıyorum.
hata aldığım satır:Kriter = Veri(X, 3) & "#" & Veri(X, 4).Value Like "*" & TextBox3.Value & "*" & "#" & Veri(X, 5)

Kod: 
Private Sub CommandButton4_Click()
    Dim S1 As Worksheet, S2 As ListBox, s3 As TextBox, Zaman As Double
    Dim X As Long, Son As Long, Veri As Variant, Say As Long
    Zaman = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
   ListBox4.Clear
    Set S1 = Sheets("Sayfa1")

    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    Veri = S1.Range("A12:p" & Son)

    ReDim Liste(1 To UBound(Veri, 1), 1 To 9)
    For X = 1 To UBound(Veri, 1)

        Kriter = Veri(X, 3) & "#" & Veri(X, 4).Value Like "*" & TextBox3.Value & "*" & "#" & Veri(X, 5)

        If Not Dizi.exists(Kriter) Then
            
            Say = Say + 1
            Dizi.Add Kriter, Say
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Veri(X, 2)
            Liste(Say, 3) = Veri(X, 3)
            Liste(Say, 4) = Veri(X, 4)
            Liste(Say, 5) = Veri(X, 5)
            Liste(Say, 6) = Veri(X, 6)
            Liste(Say, 7) = Veri(X, 16)
            
            
        End If

        Liste(Dizi.Item(Kriter), 8) = Liste(Dizi.Item(Kriter), 8) + Veri(X, 12)
        Liste(Dizi.Item(Kriter), 9) = Liste(Dizi.Item(Kriter), 9) + Veri(X, 13)

    Next
    ListBox4.List = Liste
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub
 
Korhan Ayhan' Alıntı:
Döngü bölümünü aşağıdaki gibi revize edip deneyiniz.

Kod: 
    For X = 1 To UBound(Veri, 1)
        If Veri(X, 4) Like "*" & TextBox3 & "*" Then
        Kriter = Veri(X, 3) & "#" & Veri(X, 5)
        If Not Dizi.exists(Kriter) Then
           
            Say = Say + 1
            Dizi.Add Kriter, Say
            Liste(Say, 1) = Veri(X, 1)
            Liste(Say, 2) = Veri(X, 2)
            Liste(Say, 3) = Veri(X, 3)
            Liste(Say, 4) = Veri(X, 4)
            Liste(Say, 5) = Veri(X, 5)
            Liste(Say, 6) = Veri(X, 6)
            Liste(Say, 7) = Veri(X, 16)
           
           
        End If
        Liste(Dizi.Item(Kriter), 8) = Liste(Dizi.Item(Kriter), 8) + Veri(X, 12)
        Liste(Dizi.Item(Kriter), 9) = Liste(Dizi.Item(Kriter), 9) + Veri(X, 13)
        End If
    Next
Genişletmek için tıkla ...



Hocam sağolun ama veri süzebiliyorum fakat.
c ve e sütunlarının benzersizlerini getirip aynı anda d sütununu süzemiyorum.

yukarıdaki gibi bir kod oluşturdum.
Kriter = Veri(X, 3) & "#" & Veri(X, 4).Value Like "*" & TextBox3.Value & "*" & "#" & Veri(X, 5)
satırında hata veriyor.
Yardımcı olursanız memunun olurum
 
Lütfen örnek dosya ekleyiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst