CODEWITHSUNDEEP
excelvba
Maya
Maya

Reputation: 579

Count values in column and put in new column

I would like to count how many times a value is in the column furniture, however this column may sometimes be in a different place. So I'd have to refer to the name instead of column number. Eventually create a new column where it is stated how many times that furniture appears. Below you find a simple example.

owner furniture
owen chair
mila table
will
jack chair
zoe lamp
mike lamp
maya chair

Wanted outcome

owner furniture groupsize
owen chair 3
mila table 1
will
jack chair 3
zoe lamp 2
mike lamp 2
maya chair 1

'Chair' appears 3 times in the column furniture

I'm aware of the countif formula, but I need vba. I tried several things, but neither came close. Any suggestions?

Upvotes: 2

Views: 36

Answers (1)

VBasic2008
VBasic2008

Reputation: 54807

Unique Count Using a Dictionary

Option Explicit

Sub CountFurniture()
    
    Const sColName As String = "furniture"
    Const dColName As String = "groupsize"
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    
    Dim sData As Variant
    Dim drg As Range
    Dim rCount As Long
    
    With rg
        
        rCount = .Rows.Count
        If rCount = 1 Then Exit Sub ' only headers or nothing
        
        Dim sCol As Variant: sCol = Application.Match(sColName, .Rows(1), 0)
        If IsError(sCol) Then Exit Sub ' source column not found
        sData = .Columns(sCol).Value
        
        Dim dCol As Variant: dCol = Application.Match(dColName, .Rows(1), 0)
        If IsError(dCol) Then dCol = .Columns.Count + 1
        Set drg = .Columns(dCol)
    
    End With
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
                
    Dim Key As Variant
    Dim r As Long

    For r = 2 To rCount
        Key = sData(r, 1)
        If Not IsError(Key) Then
            If Len(Key) > 0 Then
                dict(Key) = dict(Key) + 1
            End If
        End If
    Next r
    
    Dim dData As Variant: ReDim dData(1 To rCount, 1 To 1)
    
    dData(1, 1) = dColName
    
    For r = 2 To rCount
        dData(r, 1) = dict(sData(r, 1))
    Next r
    
    drg.Value = dData
    
End Sub

Upvotes: 1

Related Questions