[英]Count (Not list!) unique items in a range to assign to a variable
I need a count of unique items from a range to know how many lines to add to make room for a pivot table.我需要对某个范围内的唯一项目进行计数,以了解要添加多少行才能为数据透视表腾出空间。 Being that I know excel better then VBA I put together the following code:由于我比 VBA 更了解 excel,我将以下代码放在一起:
With ActiveSheet
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Range("F" & LR).Formula2R1C1 = "=UNIQUE(R3C:R[-1]C)"
With ActiveSheet
CT = .Cells(.Rows.Count, "F").End(xlUp).Row
End With
Range("F" & LR).ClearContents
R = "1:" & CT - LR + 3
Rows(R).Insert Shift:=xlDown
I would like to know how I can have VBA do the calulations on its own so I can avoid adding and deleting formulas from the sheet.我想知道如何让 VBA 自己进行计算,这样我就可以避免在工作表中添加和删除公式。
You can count Unique in VBA by adding to a collection or taken your post as an example by using the UNIQUE function in combination with evaluate:您可以通过添加到集合来计算 VBA 中的 Unique,或者通过将 UNIQUE 函数与评估结合使用以您的帖子为例:
With ActiveSheet
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
x = UBound(Application.Evaluate("UNIQUE(F3:F" & LR & ")"))
365
ie you don't have UNIQUE
you can use the following function.如果您没有365
即您没有UNIQUE
您可以使用以下功能。The Function and OP's Test功能和OP的测试
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the number of unique values in a range.
' Remarks: Error and empty values are excluded.
' The range can be non-contiguous.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function countUnique(SourceRange As Range) _
As Long
' Initialize error handling.
Const ProcName As String = "countUnique"
On Error GoTo clearError ' Turn on error trapping.
' Check Source Range.
If SourceRange Is Nothing Then
GoTo ProcExit
End If
' Write values from Source Range to arrays of Data Array ('Data').
Dim AreasCount As Long
AreasCount = SourceRange.Areas.Count
Dim Help As Variant
ReDim Help(1 To 1, 1 To 1)
Dim Data As Variant
ReDim Data(1 To AreasCount)
Dim rng As Range
Dim n As Long
For Each rng In SourceRange.Areas
n = n + 1
If rng.Rows.Count > 1 Or rng.Columns.Count > 1 Then
Data(n) = rng.Value
Else
Data(n) = Help
Data(1, 1) = rng.Value
End If
Next rng
' Write (unique) values from arrays of Data Array to a Dictionary ('dict').
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Dim CurrentValue As Variant
Dim i As Long
Dim j As Long
For n = 1 To AreasCount
For i = 1 To UBound(Data(n), 1)
For j = 1 To UBound(Data(n), 2)
CurrentValue = Data(n)(i, j)
If Not IsError(CurrentValue) And Not IsEmpty(CurrentValue) Then
dict(CurrentValue) = Empty
End If
Next j
Next i
Next n
' Write result (number of elements in the Dictionary).
countUnique = dict.Count
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': " & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
On Error GoTo 0 ' Turn off error trapping.
GoTo ProcExit
End Function
Sub testOP()
Dim LR As Long ' Last Row
Dim UC As Long ' Unique Count
With ActiveSheet
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
UC = countUnique(.Range(.Cells(3, "F"), .Cells(LR, "F")))
Debug.Print UC
End With
End Sub
Non-Contiguous Test非连续测试
' Select a range. Then press CTRL and select another range, etc.
' Then run the following procedure.
Sub testNonContiguous()
Dim rng As Range
If TypeName(Selection) = "Range" Then
Set rng = Selection
MsgBox "Range '" & rng.Address(0, 0) & "' contains " _
& countUnique(rng) & " unique item(s)."
End If
End Sub
Performance Tests性能测试
' Copy the following formula to A1 and copy down to the bottom of the worksheet.
' =RANDBETWEEN(1,1000000)
' Select the whole column and do a 'Copy/Paste Values'.
' Running this test took about 21 seconds on my machine.
Sub testCountUnique()
Dim rng As Range
Set rng = Range("A:A")
Debug.Print "Range '" & rng.Address(0, 0) & "' contains " _
& countUnique(rng) & " unique item(s)."
End Sub
' This is the same test using UNIQUE which I don't have. I would appreciate
' the feedback, if someone could measure the time this takes to finish.
Sub testUnique()
Dim rng As Range
Set rng = Range("A:A")
Debug.Print "Range '" & rng.Address(0, 0) & "' contains " _
& UBound(Application.Evaluate("UNIQUE(" _
& rng.Address(0, 0) & ")")) & " unique item(s)."
End Sub
You can try so:你可以试试:
Function getCountUnique(rSource As Range) As Long
With Application.WorksheetFunction
getCountUnique = .Count(.Unique(rSource, False, False))
End With
End Function
Call it from your subroutine like as:从您的子程序中调用它,如下所示:
With ActiveSheet
LR = ActiveSheet.Cells(.Rows.Count, "A").End(xlUp).Row
uniCount = getCountUnique(.Range("A3:A" & LR))
End With
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.