我想計算一個唯一數字在“A”列中出現的次數。我已經使用以下方法將唯一編號提取到“B”列中：
Range("A1:A999").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("B1:B999"), Unique:=True
現在我想計算一個數字在“A”列中出現的次數并將其寫在“C”列中
我想過這樣的事情：
- 檢查單元格值是否 A1=A,i (i=1) 然后 count = count 1
- 存盤 A1 的值（陣列）
- 檢查A2的單元格值是否存盤 --> yes: count = count 1, no: 跳轉到下一個單元格進行檢查
- 當回圈所有帶有數字的單元格時 --> 在 C1 中列印計數
- 設定計數 = 0
- 在所有帶有數字的單元格上回圈
如果這聽起來有點令人困惑，我很抱歉，但我希望你明白我的意思。
uj5u.com熱心網友回復：
使用字典
Option Explicit
Sub CountUnique()
Dim ws As Worksheet, dict As Object, k
Dim i As Long, lastrow As Long
Set dict = CreateObject("Scripting.Dictionary")
Set ws = ActiveSheet
ws.Range("A1:C1") = Array("Numbers", "Unique Numbers", "Count of Unique Numbers")
With ws
' input
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To lastrow
k = Trim(.Cells(i, 1))
dict(k) = dict(k) 1
Next
' output
i = 1
For Each k In dict.keys
i = i 1
.Cells(i, "B") = k
.Cells(i, "C") = dict(k)
Next
With .Sort
.SortFields.Clear
.SortFields.Add2 Key:=Range("B2:B" & i), _
SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
.SetRange Range("B1:C" & i)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
.Range("A1").Select
End With
MsgBox dict.Count & " Unique numbers", vbInformation
End Sub
uj5u.com熱心網友回復：
計算唯一值
Option Explicit
Sub GetUniqueColumnRangeWithCountTEST()
' Needs 'GetUniqueColumnRangeWithCount'.
Const sfCellAddress As String = "A2"
Const dfCellAddress As String = "B2"
' Create a reference to the first cell of the source one-column range.
Dim ws As Worksheet: Set ws = ActiveSheet
Dim sfCell As Range: Set sfCell = ws.Range(sfCellAddress)
' Return the unique values and their count in an array.
Dim Data As Variant: Data = GetUniqueColumnRangeWithCount(sfCell)
If IsEmpty(Data) Then Exit Sub ' see message in the Immediate window
' Write the values from the array to the destination two-column range.
Dim dfCell As Range: Set dfCell = ws.Range(dfCellAddress)
Dim drg As Range: Set drg = dfCell.Resize(UBound(Data, 1), UBound(Data, 2))
drg.Value = Data
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the unique values and their count of a one-column range
' defined by its first cell, in a 2D one-based two-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetUniqueColumnRangeWithCount( _
ByVal FirstCell As Range) _
As Variant
Const ProcName As String = "GetUniqueColumnRangeWithCount"
On Error GoTo ClearError
If FirstCell Is Nothing Then Exit Function
' Create a reference to the source one-column range.
Dim srg As Range
Dim srCount As Long
With FirstCell
Dim scrg As Range: Set scrg = .Resize(.Worksheet.Rows.Count - .Row 1)
Dim slCell As Range
Set slCell = scrg.Find("*", , xlFormulas, , , xlPrevious)
If slCell Is Nothing Then Exit Function
srCount = slCell.Row - .Row 1
Set srg = .Resize(srCount)
End With
' Write the values from the source one-column range to the Source Array.
Dim sData As Variant
If srCount = 1 Then ' one cell
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else ' multiple cells
sData = srg.Value
End If
' Write the values from the source array to the unique dictionary.
Dim uDict As Object: Set uDict = CreateObject("Scripting.Dictionary")
uDict.CompareMode = vbTextCompare
Dim uKey As Variant
Dim sr As Long
For sr = 1 To srCount
uKey = sData(sr, 1)
If Not IsError(uKey) Then ' not an error value
If Not IsEmpty(uKey) Then ' not empty
uDict(uKey) = uDict(uKey) 1 ' count
End If
End If
Next sr
Dim drCount As Long: drCount = uDict.Count
If drCount = 0 Then Exit Function ' only empty or error values
Erase sData ' since the relevant data is in the dictionary
' Write the values from the unique dictionary to the destination array.
Dim dData As Variant: ReDim dData(1 To drCount, 1 To 2)
Dim dr As Long
For Each uKey In uDict.Keys
dr = dr 1
dData(dr, 1) = uKey ' write value
dData(dr, 2) = uDict(uKey) ' write count
Next uKey
GetUniqueColumnRangeWithCount = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
轉載請註明出處，本文鏈接：https://www.uj5u.com/caozuo/375580.html