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
PivotTable
Insert>PivotTable>From Table/Range.M1 of the existing worksheet).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