我想使用 vba 获取列中数据的频率

Question

我尝试使用字典，但它只计算重复次数，但我想知道列中所有数据的确切频率
我用的是

Sub countThings()

Dim ws As Worksheet
Dim lastrow As Long, x As Long
Dim items As Object

Application.ScreenUpdating = False

Set ws = ActiveSheet

lastrow = ws.Range("B" & Rows.count).End(xlUp).Row

Set items = CreateObject("Scripting.Dictionary")
For x = 2 To lastrow
If Not items.exists(ws.Range("B" & x).Value) Then
items.Add ws.Range("B" & x).Value, 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
Else
items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
End If
Next x
items.RemoveAll

End Sub

这给了我 [1：https://i.stack.imgur.com/Mhp5g.png][1]

但我需要的是

[4:https://i.stack.imgur.com/UYOFu.png][4]

Answer 1

我想这就是你所追求的。请尝试一下。

Sub CountThings()

    Dim Ws          As Worksheet
    Dim Items       As Object           ' Scripting.Dictionary
    Dim Arr         As Variant          ' values in column B
    Dim R           As Long             ' loop couner: Rows
    Dim Key         As Variant          ' loop counter: dictionary keys
    
    Set Items = CreateObject("Scripting.Dictionary")
    
    Set Ws = ActiveSheet                ' better: define tab by name
    With Ws
        ' reading from the sheet is slow
        ' therefore read all items at once
        Arr = .Range(.Cells(2, "B"), .Cells(.Rows.Count, "B").End(xlUp)).Value
        ' this is a 1-based 2-D array, like Arr([Rows], [Column])
        ' where column is always 1 because there's only 1 column
    End With
        
    For R = 1 To UBound(Arr)
        If Items.Exists(Trim(Arr(R, 1))) Then
            Items(Trim(Arr(R, 1))) = Items(Trim(Arr(R, 1))) + 1
        Else
            Items.Add Trim(Arr(R, 1)), 1
        End If
    Next R
    
    ReDim Arr(1 To Items.Count, 1 To 2)
    R = 0
    For Each Key In Items.keys
        R = R + 1
        Arr(R, 1) = Key
        Arr(R, 2) = Items(Key)
    Next Key
    
    ' specify the top left cell of the target range
    Ws.Cells(2, "C").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
    Set Items = Nothing
End Sub

如果您确定不能有任何杂散的前导或尾随空格，则无需修剪键。

您的第二张图片不需要 VBA。可以通过这个公式生成，在C2中输入并复制下来。

=COUNTIF($B$2:$B$13,$B2)

事实上，你甚至可以在没有 VBA 的情况下完成我上面的代码的工作。在工作表的 G2 中输入此公式作为数组公式（如果您没有 Excel 365，请使用 CTL + SHIFT + ENTER 确认），在 H 中输入另一个。然后将两个公式复制下来。

[G2] =IFERROR(INDEX($B$2:$B$13, MATCH(0, COUNTIF($G$1:G1, $B$2:$B$13), 0)), "")
[H2] =IF($G2<>"",COUNTIF($B$2:$B$13,$G2),"")

Answer 2

您需要在完成计数后将值分配给 C 列，因此需要另一个循环：

Sub countThings()
    
    Dim ws As Worksheet
    Dim lastrow As Long, x As Long
    Dim items As Object
    
    Application.ScreenUpdating = False
    
    Set ws = ActiveSheet
    
    lastrow = ws.Range("B" & Rows.Count).End(xlUp).Row
    
    Set items = CreateObject("Scripting.Dictionary")
    For x = 2 To lastrow
        If Not items.exists(ws.Range("B" & x).Value) Then
            items.Add ws.Range("B" & x).Value, 1
        Else
            items(ws.Range("B" & x).Value) = items(ws.Range("B" & x).Value) + 1
        End If
    Next x
    
    For x = 2 To lastrow
        ws.Range("C" & x).Value = items(ws.Range("B" & x).Value)
    Next x

    items.RemoveAll
    Set items = Nothing

End Sub

实现您想要的更简单的方法是让 excel 像这样为您计算：

Sub countThings2()
    Dim sDataAddress As String
    
    With ActiveSheet
        sDataAddress = "$B$2:$B$" & .Cells(Rows.Count, "B").End(xlUp).Row
        
        With .Range(sDataAddress).Offset(0, 1)
            .Formula2 = "=COUNTIF(" & sDataAddress & ",B2)"
            .Value = .Value
        End With   
    End With
End Sub

Answer 3

我使用表格和 2 个函数。不是简单的方法，但有效:)

Sub Fx()
Dim str_Tab() As String, str_Text As String, str_Result As String
Dim int_Counter As Integer, int_TabItemCounter As Integer, int_LastRow As Integer
Dim rng_WorkRange As Range

int_LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set rng_WorkRange = ActiveSheet.Range("A1:A" & int_LastRow)

For i = 1 To int_LastRow
    str_Text = ActiveSheet.Range("A" & i)
    If i > 1 Then
        str_Result = IsInArray(str_Text, str_Tab)
        If str_Result = -1 Then
            int_TabItemCounter = UBound(str_Tab) - LBound(str_Tab)
            ReDim str_Tab(int_TabItemCounter)
            str_Tab(int_TabItemCounter) = str_Text
            ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
        Else
            ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
        End If  '   If str_Result = -1
    Else    '   If i > 1
        ReDim str_Tab(i)
        str_Tab(i) = str_Text
        ActiveSheet.Range("B" & i) = CountThisItem(rng_WorkRange, str_Text)
    End If  '   If i > 1
Next i
End Sub

检查函数是表中的文本 函数 IsInArray(stringToBeFound As String, arr As Variant) 只要 暗淡我只要 '如果在数组中没有找到值，则返回默认值 IsInArray = -1

For i = LBound(arr) To UBound(arr)
    If StrComp(stringToBeFound, arr(i), vbTextCompare) = 0 Then
        IsInArray = i
        Exit For
    End If
Next i
End Function

计算范围内项目的功能

Function CountThisItem(CountingRange As Range, a As String) As Integer
Dim rng_FindRange As Range
Dim LA As String

Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole)
If Not rng_FindRange Is Nothing Then
    LA = rng_FindRange.Address
    CountThisItem = 1
    Do
        Set rng_FindRange = CountingRange.Find(a, lookat:=xlWhole, after:=rng_FindRange)
        If Not rng_FindRange Is Nothing And rng_FindRange.Address <> LA Then CountThisItem = CountThisItem + 1
    Loop While rng_FindRange.Address <> LA
Else
    CountThisItem = 0
End If
End Function