計算（不是列出！）范圍內的唯一項目以分配給變量

Question

我需要對某個范圍內的唯一項目進行計數，以了解要添加多少行才能為數據透視表騰出空間。 由於我比 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

我想知道如何讓 VBA 自己進行計算，這樣我就可以避免在工作表中添加和刪除公式。

Answer 1

您可以通過添加到集合來計算 VBA 中的 Unique，或者通過將 UNIQUE 函數與評估結合使用以您的帖子為例：

With ActiveSheet
        LR = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
    x = UBound(Application.Evaluate("UNIQUE(F3:F" & LR & ")"))

Answer 2

計數唯一（字典）

• 如果您沒有365即您沒有UNIQUE您可以使用以下功能。

功能和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

非連續測試

' 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

性能測試

' 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

Answer 3

你可以試試：

Function getCountUnique(rSource As Range) As Long
    With Application.WorksheetFunction
        getCountUnique = .Count(.Unique(rSource, False, False))
    End With
End Function

從您的子程序中調用它，如下所示：

With ActiveSheet
    LR = ActiveSheet.Cells(.Rows.Count, "A").End(xlUp).Row
    uniCount = getCountUnique(.Range("A3:A" & LR))
End With