VBA filtering and counting values-CodePudding

Let consider a simplified database as shown in the picture attached below. Basically, I need to count how many "Type" match with a given "Letter". It would be extremely simple to perform this task by means of a Pivot table, but column C in my database contains multiple values, so I need to proceed in a different way.

A first idea is to:

filter the column B of my database if column C corresponds to a specific "Letter"
count the number of row containing the unique vales of "Type"

Example:

filter the column B if column C contains the letter "Gamma" (only two occurrences)
count the unique values in column B (since both occurrences have Type="French", we will count only 1 value in column B).

The desired output is shown in the cell E2.

Given that ExcelFILTER()function doesn't allow for wildcards, I used the following formula from cell E2 and down below:

=ROW(UNIQUE(FILTER($B$2:$B$15),ISNUMBER(SEARCH($D1,$C$2:$C$15))))

and it works properly, as shown in the second picture (column E). I would like, though, to perform this calculation automatically, in VBA, and I should also account for column C containing empty values. I was wondering what is the simplest and fastest way to do this. I've tried to use VBA WorksheetFunction and perform a simple For cycle, but the ROW() function is not available, since VBA has its own ROW-method. Another method would be creating a collection/dictionary object and perform the counting, but I'm sure there is a simpler way. Any idea? Thank you!

CodePudding user response：

Highlight your table and click "Insert - Table". Name it "MyTable" for now.
In the Data ribbon, in the "Get & Transform" section, click "From Table/Range" (for recent Excel, older will be very similar).
A PowerQuery editor window should pop up, displaying a new "MyTable" query.
My advice is to leave source queries alone, then create new queries that use them. So, to create a new query that starts with your "MyTable" query, click the (horribly named) "Manage - Reference" button from the Home ribbon of the PowerQuery editor.
This new query will be your details query exploding each individual letter into separate rows. On the top of the right pane is the query name, rename it to "Detail"
Click on the first column title (#) and then click the "Delete" button to remove that column.
Click on the "Letter" column title because this is the one we're going to work on next.
In the Transform ribbon, click "Split Column\By Delimiter". A dialog box should pop up.
In the Advanced Options section of the dialog box, change to split into rows, not columns.
Click "Ok" in the dialog box. You should be really close to the details table you want except for the leading spaces. With the "Letter" column still highlighted, click "Format\Trim" in the Transform ribbon.
Highlight both columns (e.g. since the second column is still highlighted, shift-click the title of the first column to select them both) and then, from the Home ribbon, click "Remove Rows\Remove Duplicates"

If you did it right (and I explained right), then clicking "Advanced Editor" from the Home ribbon should display:

let
    Source = MyTable,
    #"Removed Columns" = Table.RemoveColumns(Source,{"#"}),
    #"Split Column by Delimiter" = Table.ExpandListColumn(Table.TransformColumns(#"Removed Columns", {{"Letter", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "Letter"),
    #"Changed Type" = Table.TransformColumnTypes(#"Split Column by Delimiter",{{"Letter", Text.Trim, type text}}),
    #"Removed Duplicates" = Table.Distinct(#"Trimmed Text")
in
    #"Removed Duplicates

For now, click the "Close & Load" button (the first one in the Home ribbon). A new worksheet should appear for each of your new queries. If you were to delete them, the stored results of your two new queries will be removed but the actual queries themselves will remain as "Connection Only" queries, i.e. 'just instructions'.

Okay, so now you have options!

If you want to get your counts table via Pivot Table, you can either use your new Details worksheet, or you can change Details query to load to the data model and create a pivot table that reads from the data model.
If you want to get your counts table via PowerQuery, edit the "Details" query, click "Manage - Reference" from the Home ribbon, and then in this new query, click the first column header to highlight the column, then in the Transform ribbon click "Group By".

Either way, as with pivot tables, you'll need to refresh the data (in the Data ribbon) to re-execute the queries.

CodePudding user response：

Split to Unique Count

Option Explicit

Sub SplitToUniqueCount()
    
    Const sName As String = "Sheet1"
    Const sfRow As Long = 2
    Const uCol As Long = 3 ' Unique Column
    Const vCol As Long = 2 ' Value Column
    Const uDelimiter As String = ", "
    
    Const dName As String = "Sheet1"
    Const dfcAddress As String = "D1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount < sfRow Then Exit Sub
    
    Dim uData As Variant: uData = srg.Columns(uCol).Value
    Dim vData As Variant: vData = srg.Columns(vCol).Value
    
    Dim uArr() As String
    Dim uKey As Variant
    Dim vKey As Variant
    Dim r As Long
    Dim u As Long
    Dim uString As String
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    For r = sfRow To srCount
        uKey = uData(r, 1)
        If IsValidKey(uKey) Then
            vKey = vData(r, 1)
            If IsValidKey(vKey) Then
                uArr = Split(uKey, uDelimiter)
                For u = 0 To UBound(uArr)
                    uString = uArr(u)
                    If dict.Exists(uString) Then
                        dict(uString)(vKey) = Empty
                    Else
                        Set dict(uString) = AddToNewDictionary(vKey)
                    End If
                Next u
            End If
        End If
    Next r
    If dict.Count = 0 Then Exit Sub
    
    Dim dData As Variant: ReDim dData(1 To dict.Count, 1 To 2)
    r = 0
        
    For Each uKey In dict.Keys
        r = r   1
        dData(r, 1) = uKey
        dData(r, 2) = dict(uKey).Count
    Next uKey
    Set dict = Nothing
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    With dws.Range(dfcAddress).Resize(, 2)
        .Resize(r).Value = dData
        .Resize(r).Sort .Resize(r, 1), xlAscending, , , , , , xlNo
        .Resize(dws.Rows.Count - .Row - r   1).Offset(r).Clear
    End With
    
    MsgBox "Done.", vbInformation
    
End Sub

Function IsValidKey( _
    ByVal Key As Variant) _
As Boolean
    If Not IsError(Key) Then
        If Len(Key) > 0 Then
            IsValidKey = True
        End If
    End If
End Function

Function AddToNewDictionary( _
    ByVal Key As Variant) _
As Object
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    dict(Key) = Empty
    Set AddToNewDictionary = dict
End Function

Edit

Using a Formula

Here is a formula version. Note that I don't have 365 so your feedback is welcome.
This will require the unique values already written in column D.

Sub SplitToUniqueFormula()
    
    Const wsName As String = "Sheet1"
    Const sfRow As Long = 2
    Const uCol As Long = 3
    Const vCol As Long = 2
    Const dfcAddress As String = "D1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    Dim srg As Range: Set srg = ws.Range("A1").CurrentRegion
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount < sfRow Then Exit Sub
    
    Dim urg As Range: Set urg = srg.Columns(uCol)
    Dim vrg As Range: Set vrg = srg.Columns(vCol)
    
    Dim dFormula As String
    dFormula = "=ROW(UNIQUE(FILTER(" & vrg.Address & ",ISNUMBER(SEARCH(" _
        & dfcAddress & "," & urg.Address & "))))"
    
    Dim dfCell As Range: Set dfCell = ws.Range(dfcAddress)
    With dfCell
        Dim dlCell As Range: Set dlCell = .Resize(ws.Rows.Count - .Row   1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If dlCell Is Nothing Then Exit Sub
        Dim drg As Range: Set drg = ws.Range(dfCell, dlCell).Offset(, 1)
        drg.Formula = dFormula ' write formula
        drg.Value = drg.Value ' convert to values
    End With
     
End Sub

CodePudding user response：

Just use CountIf with asterisks (*) in front of and at the end of the search expression...

e.g. Assuming "Alpha" is in cell D1...

=COUNTIF(C:C,"*" & D1 & "*")

...will return the number of rows that have "Alpha" in them.

CodePudding user response：

Try this?

E1: "Unique Types"

E2: =UNIQUE(B2:B15)

F1: "All Letters"

F2: =IF(E2="","",CONCAT(IF(B$2:B$15=E2,C$2:C$15 & ", ","")))

(drag F2 down)

... and now you have a format where @john-joseph's answer works! ...

H1: "Letter"

H2:H15: "Alpha", "Beta", etc... I don't know how to do this via formula but I'm assuming it's a fixed set of letters.

I1: "Count"

I2: =COUNTIF(F$2:F$6,"*"&H2&"*")

(drag I2 down)