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

不是最漂亮或最优化的路线，但它会完成这项工作，我敢肯定，你可以把它理解：通过A1

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 

这将循环：A20的“工作表Sheet1”。如果该单元格不是空白的，它将检查该单词是否存在于数组中。如果不是，那么它将它添加到数组中，计数为1.如果它确实存在，那么它只会将计数加1。我希望这适合你的需求。

而且，只是要记住你的代码一眼后：你应该几乎从不使用On Error Resume Next。

Answer 2

这是extreamlly简单实用使用字典对象做。该逻辑与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开始）添加到它。然后在最后，只需掌握唯一的清单和计数，无论你需要他们。请注意，我为字典创建对象的方式允许任何人使用它 - 不需要添加对代码的引用。