samenvatting van unieke voorkomende waarden in lijst, met aantal erbij

[spiegelbeeld]

Hoe ziet het werkblad er in praktijk uit?
Meerdere kolommen en rijen, maar vooraf niet bekend hoeveel. Eerste rij bevat kolomnamen. Eén van de kolommen heet altijd “Broekmaat”. In deze kolom staan meerdere broekmaten, mogelijk met enkele lege cellen ertussen.

Wat wil ik?
Ik wil 2 rijen onder de laatste rij in de kolom Broekmaat en de kolom ernaast een samenvatting van de aantallen per maat, dus 116 2, 128 5, 140 3, etc.

Wat heb ik al?

Sub TotBroekmaat()
    Dim i, teller, aantal As Integer
    Dim lastrow, broekcol As Double
    Dim zoekbereik, plakcel, plakbereik As Range
    Dim TempArray As Variant
    
    lastrow = Range("A65536").End(xlUp).Row
    broekcol = Cells.Find(What:="Broekmaat").Column
    Set zoekbereik = Range(Cells(2, broekcol), Cells(lastrow, broekcol))
    Set plakcel = Cells(lastrow + 3, broekcol)


    If Cells(65536, broekcol).End(xlUp).Row > lastrow Then
        Range(plakcel, Cells(65536, broekcol).End(xlUp)).ClearContents
    End If
    
    Cells(lastrow + 2, broekcol) = "Totaal"
    
    TempArray = zoekbereik.Value
    
    With zoekbereik
        .Sort [zoekbereik]
        .AdvancedFilter Action:=xlFilterCopy, CopyToRange:=plakcel, Unique:=True
    End With
        
    Set plakbereik = Range(plakcel, plakcel.End(xlDown))
    
    teller = plakbereik.Rows.Count
    
    For i = 0 To teller - 1
        aantal = WorksheetFunction.CountIf(zoekbereik, Cells(plakcel.Row + i, broekcol))
        Cells(plakcel.Row + i, broekcol + 1) = aantal
    Next
    
    zoekbereik.Value = TempArray
    
End Sub

Ik heb een stuk VBA-code waarin ik eerst kijk hoeveel rijen er in gebruik zijn en kijk welke kolom de broekmaten bevat.
Vervolgens stel ik vast in welk bereik de broekmaten dus staan en waar de uiteindelijke samenvatting moet komen te staan.
Ik maak het deel waar de samenvatting moet komen te staan leeg en geef de samenvatting een titel “Totaal”
De waarden uit het bereik waarin de originele waarden staan sla ik op in een array, omdat ik deze originele waarden uiteindelijk terug wil plaatsen.
Ik sorteer de originele waarden en filter de unieke waarden eruit om deze als zijnde de samenvatting onder de kolom te plakken.
Vervolgens bepaal ik voor iedere voorkomende waarde in de samenvatting hoe vaak deze voorkomt in de originele waarden en plaats dit aantal erachter in de samenvatting.
Uiteindelijk plaats ik nog even de originele waarden terug.

So far, so good.

Wat gaat er fout?
Wanneer ‘alfabetisch’ gezien de laagste waarde, dus bijv. beginnend met de a, of in dit geval 116, 2 of meer keren in de lijst voorkomt, dan wordt deze in de samenvatting bovenaan 2x weergegeven. Wanneer deze maar 1 keer voorkomt, wordt deze ook maar 1x weergegeven. Wanneer andere waarden, dus niet de laagste waarde uit de lijst, 2 of meer keren voorkomen worden deze correct maar 1x opgenomen in de samenvatting.

Ik heb het bestand bijgevoegd om te illustreren.
Ik ben verre van expert, dus alle tips zijn welkom, maar ik kom er op dit moment vooral niet uit waarom dit probleem zich voordoet.

Bij voorbaat dank.

Bekijk bijlage Broekmaat.xlsm

 

[cow18]

bij het uitgebreid filteren had je ook de 1e rij moeten meenemen, doe je dat niet, dan aanziet hij de 1e rij als de koprij, daardoor krijg je die dubbele 116-maat.
Dus verander eens in je zoekbereik die 2 in een 1.
je had anders ook een draaitabel kunnen maken ofwel in VBA met een dictionary werken

Sub TotBroekmaat()
  Dim i, teller, aantal As Integer
  Dim lastrow, broekcol As Double
  Dim zoekbereik, plakcel, plakbereik As Range
  Dim TempArray As Variant

  lastrow = Range("A65536").End(xlUp).Row
  broekcol = Cells.Find(What:="Broekmaat").Column
  mijnbroeken = Range(Cells(2, broekcol), Cells(lastrow, broekcol))
  Set plakcel = Cells(lastrow + 3, broekcol)

  If Cells(65536, broekcol).End(xlUp).Row > lastrow Then
    Range(plakcel, Cells(65536, broekcol).End(xlUp)).ClearContents
  End If

  plakcel.Offset(-1).Value = "Totaal"

  Set dict = CreateObject("scripting.dictionary")
  For i = 1 To UBound(mijnbroeken)
    If Len(mijnbroeken(i, 1)) Then dict.Item(mijnbroeken(i, 1)) = dict.Item(mijnbroeken(i, 1)) + 1  'geen lege cel, tel 1 bij die broekmaat
  Next
  If dict.Count Then                                       'aantal unieke broekmaten <>0
    With plakcel.Resize(dict.Count)                        'hier plakken
      .Value = Application.Transpose(dict.keys)            'je broekmaten
      .Offset(, 1).Value = Application.Transpose(dict.items)  'je aantallen
      .Resize(, 2).Sort .Range("A1"), Header:=False        'sorteren op stijgende broekmaat
    End With
  End If
End Sub

 

[spiegelbeeld]

Beste cow18,

Bedankt voor je snelle antwoord, en de tip natuurlijk.
Met wat gepuzzel (alleen de 2 in een 1 veranderen was niet afdoende) heb ik het nu werkend.

Wat zou de reden zijn om het met een draaitabel te doen?
Is dat beter?, netter?, schaalbaarder?, sneller?

 

[cow18]

je werkt met >=excel2007. Dus maak je van je gegevens een tabel (op het lint invoegen>tabellen in mijn 2007).
Daarna ben je vertrokken, zonder veel toeters of bellen maak je aan de hand van die tabel een draaitabel met de gegevens die je wenst, je hebt er geen vba voor nodig.

 

[spiegelbeeld]

Sorry voor de wat late reactie.
Je hebt gelijk, maar dat vergt een aantal stappen door een net iets meer gevorderde gebruiker dan bij ons het geval is.
Nu heb ik een macro en hoeft de gebruiker alleen maar uit een ander programma de data te kopieren en in Excel in cel A1 te plakken en op de button met de macro te klikken en alles gaat vanzelf.

Bedankt in ieder geval.