Listboxa Benzersiz Değerleri Listeleme ve Toplama İşlemi

[walabi]

Merhaba,

Aşağıda excel sayfası üzerinden listbox2 ye textbox1 e metin girerek filtreleme yaptırmaktayım. Ancak Benzersiz şeklinde listeleme yaptırıp daha sonra tutar sütununu toplatmam gerekiyor. Bununla ilgili forumda çok örnek var ancak yine de desteğe ihtiyaç duydum.

B sütununda Fatura Numarası,
F sütununda Firma Ünvanı,
L sütununda Fatura Tutarı,

Textbox1 e metin girerek firma ünvanlarına göre filtreleme yapabiliyorum aşağıdaki kod ile ( F sütunu ). Ancak tekrarlayan veri satırları mevcut. Tekrarlayan verileri benzersiz verilere dönüştürmem gerekiyor, Fatura Numarası sütununa göre ( B sütunu ). Son olarak L sütunundaki tutarları Fatura Numarası sütununa göre toplatmam gerekiyor.

Destek alabilirsem memnun olurum.

Sub Firma_Ara_Kademe()

Set S1 = Sheets("KADEME_FATURA")
ListBox2.ColumnCount = 5
ListBox2.ColumnWidths = "100;70;170;80;5"
Dim a As Long, i As Long

    ReDim dizial(1 To 5, 1 To 1)
    If TextBox2.Text = "" Then Exit Sub
    ListBox2.Clear
    If Len(TextBox1) >= 3 Then
    For i = 2 To S1.Cells(Rows.Count, "A").End(3).Row
        If UCase(Replace(Replace(S1.Cells(i, "F") & S1.Cells(i, "H"), "ı", "I"), "i", "İ")) Like _
        "*" & UCase(Replace(Replace(TextBox1.Text, "ı", "I"), "i", "İ")) & "*" Then
       
       
            a = a + 1
            ReDim Preserve dizial(1 To 5, 1 To a)
            dizial(1, a) = S1.Cells(i, "F")
            dizial(2, a) = Format(S1.Cells(i, "A"), "dd.mm.yyyy")
            dizial(3, a) = S1.Cells(i, "Q")
           
            ' Bu sütuna excel sayfasında L sütununun verilerinin toplamı aldırılmalı
            If S1.Cells(i, "L") <> "" Then
            dizial(4, a) = Format(S1.Cells(i, "L"), "#,##0.00")
            End If
       
        End If
    Next i
    End If
    ListBox2.Column = dizial
    Erase dizial
    a = Empty
    i = Empty
   
   
End Sub

 

[Erdem Akdemir]

Örnek dosya ekleyebilir misiniz.

 

[walabi]

Örnek dosya ektedir. Textbox1 e örneğin PUTZ şeklinde bir metin girildiğinde listboxlara veri yükleniyor.

 

[walabi]

Merhaba, mevcut kodunuzu şöyle güncelleyip deneyebilir misiniz;

Sub Firma_Ara_Kademe()
    Dim S1 As Worksheet
    Set S1 = Sheets("KADEME_FATURA")
   
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
   
    With ListBox2
        .Clear
        .ColumnCount = 5
        .ColumnWidths = "100;70;170;80;80"
    End With
   
    Dim i As Long
    Dim faturaNo As String
    Dim firmaUnvan As String
    Dim faturaTutar As Double
    Dim tarih As String
    Dim qValue As String
    Dim key As Variant
   
    If TextBox2.Text = "" Then Exit Sub
   
    If Len(TextBox1.Text) >= 3 Then
        For i = 2 To S1.Cells(S1.Rows.Count, "A").End(xlUp).Row
            firmaUnvan = UCase(Replace(Replace(S1.Cells(i, "F").Value & S1.Cells(i, "H").Value, "ı", "I"), "i", "İ"))
            If firmaUnvan Like "*" & UCase(Replace(Replace(TextBox1.Text, "ı", "I"), "i", "İ")) & "*" Then
                faturaNo = S1.Cells(i, "B").Value ' Fatura Numarası (B sütunu)
                tarih = Format(S1.Cells(i, "A").Value, "dd.mm.yyyy")
                qValue = S1.Cells(i, "Q").Value
               
                If IsNumeric(S1.Cells(i, "L").Value) Then
                    faturaTutar = S1.Cells(i, "L").Value
                Else
                    faturaTutar = 0
                End If
               
                If dict.Exists(faturaNo) Then
                    dict(faturaNo)(3) = dict(faturaNo)(3) + faturaTutar
                Else
                    dict.Add faturaNo, Array(S1.Cells(i, "F").Value, tarih, qValue, faturaTutar, faturaNo)
                End If
            End If
        Next i
    End If
   
    If dict.Count > 0 Then
        Dim dizial() As Variant
        ReDim dizial(1 To 5, 1 To dict.Count)
        Dim a As Long
        a = 1
        For Each key In dict.Keys
            dizial(1, a) = dict(key)(0)
            dizial(2, a) = dict(key)(1)
            dizial(3, a) = dict(key)(2)
            dizial(4, a) = Format(dict(key)(3), "#,##0.00")
            dizial(5, a) = dict(key)(4)
            a = a + 1
        Next key
        ListBox2.Column = dizial
    End If
   
    Erase dizial
    Set dict = Nothing
End Sub

Cevap için teşekkürler.

Kodlar sanırım sadece ilk satır değerlerini getirmekte. Kodlarda toplama işlemi yoksa , benzersiz değerleri oluşturma konusunda doğru çalışıyor. Toplam aldırma işlemi varsa eksik / hatalı çalışıyor, yanlış anlamadıysam.

 

[walabi]

Sayın pitchoute, son paylaştığınız kodlar üzerinde ufak birkaç değişiklik yaparak kendi dosyamda çalışır hale getirdim.

Dosyayıda çalışır hali ile ekliyorum. Destek için teşekkürler.

Sub Firma_Ara_Kademe_Yeni()
  Dim S1 As Worksheet
    Set S1 = Sheets("KADEME_FATURA")

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    With ListBox2
        .Clear
        .ColumnCount = 5
        .ColumnWidths = "100;70;170;80;80"
    End With

    Dim i As Long
    Dim faturaNo As String
    Dim firmaUnvan As String
    Dim faturaTutar As Double
    Dim tarih As String
    Dim qValue As String
    Dim key As Variant

    If TextBox1.Text = "" Then Exit Sub

    If Len(TextBox1.Text) >= 3 Then
        For i = 2 To S1.Cells(S1.Rows.Count, "A").End(xlUp).Row
            firmaUnvan = UCase(Replace(Replace(S1.Cells(i, "F").Value & S1.Cells(i, "B").Value, "ı", "I"), "i", "İ"))
            If firmaUnvan Like "*" & UCase(Replace(Replace(TextBox1.Text, "ı", "I"), "i", "İ")) & "*" Then
                faturaNo = S1.Cells(i, "B").Value
                tarih = Format(S1.Cells(i, "A").Value, "dd.mm.yyyy")
                qValue = S1.Cells(i, "Q").Value

                If IsNumeric(S1.Cells(i, "L").Value) Then
                    faturaTutar = S1.Cells(i, "L").Value
                Else
                    faturaTutar = 0
                End If

                If dict.Exists(faturaNo) Then
                    Dim tempArray As Variant
                    tempArray = dict(faturaNo)
                    tempArray(3) = tempArray(3) + faturaTutar
                    dict(faturaNo) = tempArray
                Else
                    dict.Add faturaNo, Array(S1.Cells(i, "F").Value, tarih, faturaNo, faturaTutar, qValue)
                End If
            End If
        Next i
    End If

    If dict.Count > 0 Then
        Dim dizial() As Variant
        ReDim dizial(1 To 5, 1 To dict.Count)
        Dim a As Long
        a = 1
        For Each key In dict.Keys
            dizial(1, a) = dict(key)(0)
            dizial(2, a) = dict(key)(1)
            dizial(3, a) = dict(key)(2)
            dizial(4, a) = Format(dict(key)(3), "#,##0.00")
            'dizial(5, a) = dict(key)(4)
            a = a + 1
        Next key
        ListBox2.Column = dizial
    End If

    Erase dizial
    Set dict = Nothing
End Sub