Unieke waarden tellen uit meerdere kolommen VBA

[royb73]

Beste,

Ik heb een lijst (sheet "typelijsttotaal") met aantal complexnummers (kolom C), Woningtypes (kolom K) en subtypes (kolom I). De woningtypes kan per complex meerdere keren voorkomen, echter moet hij dan de unieke subtypes zoeken.

Voorbeeld (zie ook bijlage):

Kolom C Kolom I Kolom K
230 C0.TL B
230 C0.TL B
230 A1.TR V
230 A2.TL V
230 A2.TL V
230 E2.TR S
245 etc etc
245
245
etc

Ik ben op zoek naar een VBA code die per complex de aantal unieke woningtypes optelt in sheet "Samenvatting".

Ik zou dan de volgende waarden moeten krijgen in sheet "Samenvatting"

complex B V S
230 1 2 1
245 etc.
Bekijk bijlage Testbestand Unieke waarden.xls

Wie kan mij hiermee helpen. Ben namelijk een beginner op het gebied van VBA.

Bij voorbaat dank.

Mvg

Roy

 

[wampier]

Mag de set verder gesorteerd worden? of wil je het in willekeurige volgorde kunnen draaien? Is het waarschijnlijk dat de typering wordt aangepast in de toekomst of is dat een vaste set?

 

[royb73]

Beste Wampier,

Sorteren is prima. Ik heb trouwens dit ook met draaitabel geprobeerd, maar dit gaat niet goed omdat elke waarde (ook de dubbele waarden) worden opgeteld. Typering is in eerste instantie vaste waarde, maar kan ook aangepast worden.

Mvg

 

[wampier]

Als de typering aangepast kan worden (of dingen toegevoegd) is een vaste tabel niet handig. Een dynamisch opgebouwde tabel kan wel, maar is iets meer werk.

 

[royb73]

Beste Wampier,

In principe als dit lijst is opgebouwd en daarna de macro wordt uitgevoerd dan hoeft er niets meer veranderd te worden. Ik heb bij een oud collega gezien dat hij iets in VBA had gebouwd, waarbij een tabel met unieke waarden werd gegenereerd vanuit een lijst met meerdere kolommen. Ik stuur een voorbeeldje mee, waarin je kunt zien wat uiteindelijk de bedoeling is. De code zou vanuit de lijst met data dit tabel moeten genereren.

Mvg

Bekijk bijlage Unieke waarden tabel.xlsx

 

[wampier]

Gooi dit eens in een module in je voorbeeld en maak een extra tab "result" aan

Type complexopslag
    complex As String
    types As Object
End Type


Sub t()
    Dim uniek As Object
    complexnr = [c12].Value
    Set uniek = CreateObject("Scripting.Dictionary")
    Dim complex() As complexopslag
    ReDim complex(0)
    
    For Each cel In Range([c12], [c50000].End(xlUp).Offset(1))
        If cel.Value = complexnr Then
            combinatie = cel.Offset(0, 6) & "-" & cel.Offset(0, 8)
            If Not uniek.Exists(combinatie) Then
                uniek.Add combinatie, cel.Offset(0, 8).Value
            End If
        Else
            complex(UBound(complex)).complex = complexnr
            complexnr = cel
            Set complex(UBound(complex)).types = CreateObject("Scripting.Dictionary")
            sleutels = uniek.Items
            For i = 0 To uniek.Count - 1
                If complex(UBound(complex)).types.Exists(sleutels(i)) Then
                    complex(UBound(complex)).types(sleutels(i)) = complex(UBound(complex)).types(sleutels(i)) + 1
                Else
                    complex(UBound(complex)).types.Add Key:=sleutels(i), Item:=1
                End If
            Next i
            ReDim Preserve complex(UBound(complex) + 1)
            Set uniek = CreateObject("Scripting.Dictionary")
            combinatie = cel.Offset(0, 6) & "-" & cel.Offset(0, 8).Value
            uniek.Add combinatie, cel.Offset(0, 8).Value
        End If
    Next cel
    With Sheets("result")
        For i = 0 To UBound(complex) - 1
            .[a1].Offset(i) = complex(i).complex
            For j = 0 To complex(i).types.Count - 1
                sleutels = complex(i).types.Keys
                aantal = complex(i).types.Items
                .[b1].Offset(i, j) = sleutels(j) & " " & aantal(j)
            Next j
        Next i
    End With
    
End Sub

De formatering is nog niet helemaal correct, maar daar was ik nog niet aan toegekomen. Ik wilde je dit vast geven omdat de resultaten volgens mij wel kloppen met wat je wil bereiken.

 

[royb73]

Beste Wampier,

Dit is precies wat ik bedoel. Met 1 druk op de knop wordt er een samenvatting afgedrukt van de unieke waarden waarbij er gekeken wordt naar meerdere kolommen.
Is het mogelijk om deze gegevens in een tabel (zoals in het 2e bestand) neer te zetten. Dus in rij 2 (bijvoorbeeld) en dan kolommen met Complex (A2) / BG (B2) / VG (C2) / B (D2 etc) / V/ S / W. Dan in kolom A onder Complex de complexnummers (zoals 223, 224, 230 etc gesorteerd) en in de tabel de waarden.

Hopelijk heb je er tijd voor om dit voor elkaar te krijgen.

Alvast bedankt voor je moeite.

Mvg

 

[wampier]

Moet de volgorde vast zijn? anders kun je gewoon kijken wat er in de lijst voorkomt en daar een lijst van maken. Items die niet momenteel in de lijst staan worden dan niet gegenereerd.

 

[royb73]

Wampier,

De volgorde mag vast zijn, maar hoeft niet. Indien er wijziging plaatsvindt, dan neem ik aan dat ik de macro opnieuw kan draaien waardoor de lijst opnieuw opgemaakt wordt waarbij de "oude" gegevens gewist worden in tabblad "Result".

Mvg

 

[wampier]

met automatische opbouw

Type complexopslag
    complex As String
    types As Object
End Type


Sub t()
    Dim uniek As Object
    complexnr = [c12].Value
    Set uniek = CreateObject("Scripting.Dictionary")
    Dim complex() As complexopslag
    ReDim complex(0)
    
    For Each cel In Range([c12], [c50000].End(xlUp).Offset(1))
        If cel.Value = complexnr Then
            combinatie = cel.Offset(0, 6) & "-" & cel.Offset(0, 8)
            If Not uniek.Exists(combinatie) Then
                uniek.Add combinatie, cel.Offset(0, 8).Value
            End If
        Else
            complex(UBound(complex)).complex = complexnr
            complexnr = cel
            Set complex(UBound(complex)).types = CreateObject("Scripting.Dictionary")
            sleutels = uniek.Items
            For i = 0 To uniek.Count - 1
                If complex(UBound(complex)).types.Exists(sleutels(i)) Then
                    complex(UBound(complex)).types(sleutels(i)) = complex(UBound(complex)).types(sleutels(i)) + 1
                Else
                    complex(UBound(complex)).types.Add Key:=sleutels(i), Item:=1
                End If
            Next i
            ReDim Preserve complex(UBound(complex) + 1)
            Set uniek = CreateObject("Scripting.Dictionary")
            combinatie = cel.Offset(0, 6) & "-" & cel.Offset(0, 8).Value
            uniek.Add combinatie, cel.Offset(0, 8).Value
        End If
    Next cel
    
    With Sheets("result")
        .Cells.Clear
        .[a1].Value = "Complex"
        For i = 0 To UBound(complex) - 1
            .[a2].Offset(i) = complex(i).complex
            sleutels = complex(i).types.Keys
            aantal = complex(i).types.Items
            For j = 0 To complex(i).types.Count - 1
                Set balk = .Range(.[b1], .[ia1].End(xlToLeft)).Find(sleutels(j))
                If balk Is Nothing Then
                    .[ia1].End(xlToLeft).Offset(0, 1).Value = sleutels(j)
                    .[ia1].End(xlToLeft).Offset(i + 1) = aantal(j)
                Else
                    balk.Offset(i + 1) = aantal(j)
                End If
            Next j
        Next i
    End With
    
End Sub

 

[royb73]

Beste Wampier,

Dit gaat goed. Echter mis ik 2 kolommen te weten B en V. Nu worden de aantallen van B onder BG opgeteld en van V bij VG.

Mvg

 

[wampier]

Ik zie het al, de find is standaard "part" Om het altijd te laten werken kun je dit gebruiken:

Set balk = .Range(.[b1], .[ia1].End(xlToLeft)).Find(sleutels(j), , , xlWhole)

 

[royb73]

Beste Wampier,

Dit werkt prima!

Ik heb met m.b.v. een macro een tabel met opmaak toegevoegd en vervolgens rij 2 (waarde 0) verwijderd, totaalrijen toegevoegd en gesorteerd op complexnummer (laag naar hoog).

Ik heb de volgende code hiervoor en vroeg mij af of dit op een normale VBA code herschreven kan worden. Nu worden letterlijk mijn handelingen opgenomen namelijk.

Sub Macro1()
'
' Macro1 Macro
'

'
Range("A1").Select
ActiveSheet.ListObjects.Add(xlSrcRange, Range("$A$1:$G$20"), , xlYes).Name = _
"Tabel4"
Range("Tabel4[#All]").Select
ActiveSheet.ListObjects("Tabel4").TableStyle = "TableStyleMedium2"
ActiveSheet.ListObjects("Tabel4").ShowTotals = True
ActiveWorkbook.Worksheets("Result").ListObjects("Tabel4").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Result").ListObjects("Tabel4").Sort.SortFields.Add _
Key:=Range("Tabel4[[#Headers],[#Data],[Complex]]"), SortOn:=xlSortOnValues _
, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Result").ListObjects("Tabel4").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Rows("2:2").Select
Selection.Delete Shift:=xlUp
Range("Tabel4[[#Totals],]").Select
ActiveSheet.ListObjects("Tabel4").ListColumns("S").TotalsCalculation = _
xlTotalsCalculationSum
Range("Tabel4[[#Totals],[VG]]").Select
ActiveSheet.ListObjects("Tabel4").ListColumns("VG").TotalsCalculation = _
xlTotalsCalculationSum
Range("Tabel4[[#Totals],[BG]]").Select
ActiveSheet.ListObjects("Tabel4").ListColumns("BG").TotalsCalculation = _
xlTotalsCalculationSum
Range("Tabel4[[#Totals],]").Select
ActiveSheet.ListObjects("Tabel4").ListColumns("B").TotalsCalculation = _
xlTotalsCalculationSum
Range("Tabel4[[#Totals],[V]]").Select
ActiveSheet.ListObjects("Tabel4").ListColumns("V").TotalsCalculation = _
xlTotalsCalculationSum
End Sub

 

[wampier]

Het kan wel wat netter, maar indien het niet noodzakelijk is, zou ik dat in dit geval grotendeels zo laten. Sowieso is het bovenste deel al bijna zo compact als het zal worden.

Het onderste deel kan je omschrijven om "select" te vermijden, maar omdat je custom headers gebruikt kun je eigenlijk geen extra regels besparen (zonder het weer minstens net zo complex te maken).

 

[royb73]

Beste Wampier,

Dit werkt perfect. Ik vind het ook niet netjes uitzien in de code, maar resultaat is hetzelfde.

Nogmaals bedankt voor jouw tijd. Ik heb nog een aantal andere vragen m.b.t. VBA voor andere rapporten die zal ik t.z.t. wel stellen. Hopelijk kan je mij weer een handje helpen:thumb:

Met vriendelijke groet,

Roy