Excel VBA可计算和打印不同的值

Question

我必须计算列中不同值的数量，并使用不同的值打印它并在另一个表中计数。 我正在处理这段代码，但由于某种原因，它没有返回任何结果。 谁能告诉我我错过了哪一块！

Dim rngData As Range
Dim rngCell As Range
Dim colWords As Collection
Dim vntWord As Variant
Dim Sh As Worksheet
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet
Dim Sh3 As Worksheet

On Error Resume Next

Set Sh1 = Worksheets("A")
Set Sh2 = Worksheets("B")
Set Sh3 = Worksheets("C")

Sh1.Range("A2:B650000").Delete

Set Sh = Worksheets("A")
Set r = Sh.AutoFilter.Range
r.AutoFilter Field:=24
r.AutoFilter Field:=24, Criteria1:="My Criteria"

Sh1.Range("A2:B650000").Delete

Set colWords = New Collection

Dim lRow1 As Long
lRow1 = <some number>

Set rngData = <desired range>
For Each rngCell In rngData.Cells
    colWords.Add colWords.Count + 1, rngCell.Value
    With Sh1.Cells(1 + colWords(rngCell.Value), 1)
        .Value = rngCell.Value
        .Offset(0, 1) = .Offset(0, 1) + 1
    End With
Next

以上是我的完整代码..我的所需结果很简单，计算一列中每个单元格的出现次数，并将其打印在另一张表中，并显示出现次数。 谢谢！

谢谢！ 资产净值。

Answer 1

使用字典对象，这非常容易和实用。 逻辑类似于Kittoes的答案，但字典对象更快，更有效，并且您可以输出所有键和项目的数组，您想在此处执行此操作。 我已经简化了从A列生成列表的代码，但是你会明白这个想法。

Sub UniqueReport()

Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
Dim varray As Variant, element As Variant

varray = Range("A1:A10").Value

'Generate unique list and count
For Each element In varray
    If dict.exists(element) Then
        dict.Item(element) = dict.Item(element) + 1
    Else
        dict.Add element, 1
    End If
Next

'Paste report somewhere
Sheet2.Range("A1").Resize(dict.Count, 1).Value = _
    WorksheetFunction.Transpose(dict.keys)
Sheet2.Range("B1").Resize(dict.Count, 1).Value = _
    WorksheetFunction.Transpose(dict.items)

End Sub

工作原理 ：您只需将范围转储到变量数组中即可快速循环，然后将每个范围添加到字典中。 如果它存在，你只需要带上它们的键（从1开始）并添加一个。 然后在最后，只需将唯一列表和计数打到你需要的任何地方。 请注意，我为字典创建对象的方式允许任何人使用它 - 无需添加对代码的引用。

Answer 2

不是最漂亮或最优化的路线，但它会完成工作，我很确定你能理解它：

Option Explicit

Sub TestCount()

Dim rngCell As Range
Dim arrWords() As String, arrCounts() As Integer
Dim bExists As Boolean
Dim i As Integer, j As Integer

ReDim arrWords(0)

For Each rngCell In ThisWorkbook.Sheets("Sheet1").Range("A1:A20")
    bExists = False

    If rngCell <> "" Then
        For i = 0 To UBound(arrWords)
            If arrWords(i) = rngCell.Value Then
                bExists = True
                arrCounts(i) = arrCounts(i) + 1
            End If
        Next i

        If bExists = False Then
            ReDim Preserve arrWords(j)
            ReDim Preserve arrCounts(j)

            arrWords(j) = rngCell.Value
            arrCounts(j) = 1

            j = j + 1
        End If
    End If
Next

For i = LBound(arrWords) To UBound(arrWords)
    Debug.Print arrWords(i) & ", " & arrCounts(i)
Next i

End Sub

这将在“Sheet1”上循环通过A1：A20。 如果单元格不是空白，它将检查数组中是否存在该单词。 如果没有，那么它将它添加到数组中，如果它确实存在，那么它只是将1加到计数中。 我希望这符合你的需求。

另外，在看了一下你的代码后，请记住一些事情：你几乎不应该使用On Error Resume Next 。