Çoklu kriterlere göre benzersizleri listeleyip toplamak

B

bebar

Katılım
12 Kasım 2014
Mesajlar
255
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-05-2023
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

B

bebar

Katılım
12 Kasım 2014
Mesajlar
255
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-05-2023
Benzer bir örnek dosyada paylaşırsanız, revize edip kendime uyarlayabilirim.
Çok bakındım ama bulamadım
 
B

bebar

Katılım
12 Kasım 2014
Mesajlar
255
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-05-2023
Kardeşim beni yanlış anladın bahsettiğim formül değil
teşekkür ederim.
 
Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,248
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
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
 
B

bebar

Katılım
12 Kasım 2014
Mesajlar
255
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-05-2023
hocam çok teşekkür ederim.
 
B

bebar

Katılım
12 Kasım 2014
Mesajlar
255
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-05-2023
hocam çok olmazsam bir sorum daha olacak
bir texbox ım var oraya girdiğim değerri d sütununda içerenleri bulup sonra toplatabilirmiyim.
 
Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,248
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
Textbox nerede,userformdamı , sayfadamı? :cool:
 
B

bebar

Katılım
12 Kasım 2014
Mesajlar
255
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-05-2023
userform
textbox3
listboxımda userformda
 
B

bebar

Katılım
12 Kasım 2014
Mesajlar
255
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-05-2023
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
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,124
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
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
 
Orion1

Orion1

Uzman
Uzman
Katılım
1 Mart 2005
Mesajlar
22,248
Excel Vers. ve Dili
Win7 Home Basic TR 64 Bit

Ofis-2010-TR 32 Bit
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
 
B

bebar

Katılım
12 Kasım 2014
Mesajlar
255
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-05-2023
Adamsın hocam.
Çok teşekkür ederim.
 
B

bebar

Katılım
12 Kasım 2014
Mesajlar
255
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-05-2023
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
 
B

bebar

Katılım
12 Kasım 2014
Mesajlar
255
Excel Vers. ve Dili
2013
Altın Üyelik Bitiş Tarihi
15-05-2023
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
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,124
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Lütfen örnek dosya ekleyiniz.
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst