VBA 的动态 COUNTIF 矩阵
Dynamic COUNTIF matrix with VBA
我有一个列表，其中一个项目作为错误判断。
现在我想计算一个项目有多少错误。
通常在 excel 中，我会为此使用 COUNTIF 函数。
构建一个“矩阵”。在 Y 轴上，项目，在 X 轴上的错误。用 COUNTIF 填充整个矩阵，然后我可以制作图表。
但是 VBA 在动态范围内这可能吗？
最后，我需要这样的信息，例如，MA1AD1 有 4 个 BRIDGE 错误
转换数据（数据透视表，VBA）
- 写代码很好，但是要花多长时间：半小时，一小时，更多？
数据透视表
- 使用枢轴 table 你可以在不到一分钟内处理这个问题。
- Select范围。
- Select
Insert>PivotTable>From Table/Range.
- 在 window 打开 select 的位置（在图像中，例如，现有工作表的
M1）。
- 在枢轴 table 中，将第一列拖到
Rows，将第三列拖到 Columns，然后将两者中的任何一个拖到 Values 并使用它。
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
我有一个列表，其中一个项目作为错误判断。 现在我想计算一个项目有多少错误。 通常在 excel 中，我会为此使用 COUNTIF 函数。 构建一个“矩阵”。在 Y 轴上，项目，在 X 轴上的错误。用 COUNTIF 填充整个矩阵，然后我可以制作图表。
但是 VBA 在动态范围内这可能吗？
最后，我需要这样的信息，例如，MA1AD1 有 4 个 BRIDGE 错误
转换数据（数据透视表，VBA）
- 写代码很好，但是要花多长时间：半小时，一小时，更多？
数据透视表
- 使用枢轴 table 你可以在不到一分钟内处理这个问题。
- Select范围。
- Select
Insert>PivotTable>From Table/Range. - 在 window 打开 select 的位置（在图像中，例如，现有工作表的
M1）。 - 在枢轴 table 中，将第一列拖到
Rows，将第三列拖到Columns，然后将两者中的任何一个拖到Values并使用它。
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