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

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

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 

工作原理 ：只需将范围转储到variables数组中即可快速循环，然后将其添加到字典中。 如果存在的话，你只要把他们关键的项目（从1开始）添加一个。 然后在最后，只需掌握唯一的清单和数量，无论你需要他们。 请注意，我为字典创build对象的方式允许任何人使用它 – 不需要添加对代码的引用。

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.如果它存在，则只需将计数加1。 我希望这适合你的需求。

另外，在浏览你的代码之后，你应该记住：你几乎不应该使用On Error Resume Next 。