Dynamic COUNTIF matrix with VBA-CodePudding

I have a list, in where an item as an error judgement. Now I want to count how many errors an items have. Normally in excel I would use the COUNTIF function for that. Build a "matrix". On Y-axis, the Items, on X-axis the errors. Fill the whole matrix with the COUNTIF, and from that I can make a chart.

But is this possible with VBA on a dynamic range?

At the end, I need the info that, for example, MA1AD1 has 4 BRIDGE errors

CodePudding user response：

Transform Data (PivotTable, VBA)

Writing a code is nice, but how long will it take: half an hour, an hour, more?

PivotTable

With a pivot table you can handle this in less than a minute.
Select the range.
Select Insert>PivotTable>From Table/Range.
In the window that opens select the location (in the image e.g., M1 of the existing worksheet).
In the pivot table, drag the first column to Rows, the third to Columns and again, any of the two, to Values and play with it.

VBA

Option Explicit

Sub CountErrors()
    Const ProcName As String = "CountErrors"
    On Error GoTo ClearError
    
    Const sName As String = "Sheet1"
    Const sFirstCellAddress As String = "A1"
    Const srCol As Long = 1
    Const scCol As Long = 3
    
    Const dName As String = "Sheet1"
    Const dFirstCellAddress As String = "E1"
    Dim dHeader As String: dHeader = "" ' Top-Left Header
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    
    Dim srg As Range
    Dim srCount As Long
    With RefCurrentRegion(sws.Range(sFirstCellAddress))
        srCount = .Rows.Count - 1
        If srCount < 1 Then Exit Sub ' no data or only headers
        Set srg = .Resize(srCount).Offset(1)
        If Len(dHeader) = 0 Then dHeader = .Cells(1)
    End With
    
    Dim srData As Variant: srData = GetRange(srg.Columns(srCol))
    Dim srDict As Object: Set srDict = DictColumnIncrement(srData, , 2)
    
    Dim scData As Variant: scData = GetRange(srg.Columns(scCol))
    Dim scDict As Object: Set scDict = DictColumnIncrement(scData, , 2)
    
    Dim drCount As Long: drCount = srDict.Count   1
    Dim dcCount As Long: dcCount = scDict.Count   1
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    Dim Key As Variant
    Dim r As Long
    
    ' Top-Left Header
    dData(1, 1) = dHeader
    ' Row Labels
    For Each Key In srDict.Keys
        dData(srDict(Key), 1) = Key
    Next Key
    ' Column Labels
    For Each Key In scDict.Keys
        dData(1, scDict(Key)) = Key
    Next Key
    ' Data
    For r = 1 To srCount
        If srDict.Exists(srData(r, 1)) Then
            If scDict.Exists(scData(r, 1)) Then
                dData(srDict(srData(r, 1)), scDict(scData(r, 1))) _
                    = dData(srDict(srData(r, 1)), scDict(scData(r, 1)))   1
            End If
        End If
    Next r
    Erase srData: Erase scData: Set srDict = Nothing: Set scDict = Nothing
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    With dws.Range(dFirstCellAddress).Resize(, dcCount)
        .Resize(drCount).Value = dData
        .Resize(dws.Rows.Count - .Row - drCount   1).Offset(drCount).Clear
        .Font.Bold = True ' headers
        .Resize(drCount - 1, 1).Offset(1).Font.Bold = True ' row labels
        .EntireColumn.AutoFit
    End With
    
    MsgBox "Errors counted.", vbInformation
    
ProcExit:
    Exit Sub
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns a reference to the range starting with the first cell
'               of a range and ending with the last cell of the first cell's
'               Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegion( _
    ByVal FirstCell As Range) _
As Range
    Const ProcName As String = "RefCurrentRegion"
    On Error GoTo ClearError

    If FirstCell Is Nothing Then Exit Function
    With FirstCell.Cells(1).CurrentRegion
        Set RefCurrentRegion = FirstCell.Resize(.Row   .Rows.Count _
            - FirstCell.Row, .Column   .Columns.Count - FirstCell.Column)
    End With

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range ('rg') in a 2D one-based array.
' Remarks:      If ˙rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal rg As Range) _
As Variant
    Const ProcName As String = "GetRange"
    On Error GoTo ClearError
    
    If rg.Rows.Count   rg.Columns.Count = 2 Then ' one cell
        Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
        GetRange = Data
    Else ' multiple cells
        GetRange = rg.Value
    End If

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the unique values from a column ('ColumnIndex')
'               of a 2D array ('Data') in the keys of a dictionary,
'               and returns an integer sequence in its items.
' Remarks:      Error values and blanks are excluded.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function DictColumnIncrement( _
    ByVal Data As Variant, _
    Optional ByVal ColumnIndex As Variant, _
    Optional ByVal FirstInteger As Long = 1, _
    Optional ByVal IntegerStep As Long = 1) _
As Object
    Const ProcName As String = "DictColumnIncrement"
    On Error GoTo ClearError
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive
    
    Dim c As Long
    
    If IsMissing(ColumnIndex) Then
       c = LBound(Data, 2) ' use first column index
    Else
       c = CLng(ColumnIndex)
    End If
    
    Dim i As Long: i = FirstInteger
    
    Dim Key As Variant
    Dim r As Long
    
    For r = LBound(Data, 1) To UBound(Data, 1)
        Key = Data(r, c)
        If Not IsError(Key) Then ' exclude error values
            If Len(CStr(Key)) > 0 Then ' exclude blanks
                If Not dict.Exists(Key) Then
                    dict(Key) = i
                    i = i   IntegerStep
                End If
            End If
        End If
    Next r
   
    If dict.Count = 0 Then Exit Function ' only error values and blanks
    
    Set DictColumnIncrement = dict

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function