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開始）添加到它。然後在最後，只需掌握唯一的清單和計數，無論你需要他們。請注意，我爲字典創建對象的方式允許任何人使用它 - 不需要添加對代碼的引用。