我有一個串列，在其中一個專案作為錯誤判斷。現在我想計算一個專案有多少錯誤。通常在 excel 中我會使用 COUNTIF 函式。建立一個“矩陣”。在 Y 軸上是專案，在 X 軸上是錯誤。用 COUNTIF 填充整個矩陣，然后我可以制作一個圖表。
但是在動態范圍內使用 VBA 是否可行？
最后，我需要資訊，例如 MA1AD1 有 4 個 BRIDGE 錯誤
uj5u.com熱心網友回復：
轉換資料（資料透視表，VBA）
- 撰寫代碼很好，但需要多長時間：半小時，一個小時，還是更多？
資料透視表
- 使用資料透視表，您可以在不到一分鐘的時間內完成此操作。
- 選擇范圍。
- 選擇
Insert>PivotTable>From Table/Range。 - 在打開的視窗中選擇位置（在影像中，例如
M1現有作業表的位置）。 - 在資料透視表中，將第一列拖到
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/qukuanlian/439847.html
上一篇：鎖定特定作業表中的單元格