計算每個唯一字符串在一個範圍內的出現次數

Question

我有一個大範圍的值，其間有一些空白，我想知道如何找到所有不同的值，每個值都有自己的總值範圍。

例如，我有（在範圍A1：D5）：

| Low | Low | --- | Low | 
| Low | High| --- | Low | 
| --- | --- | --- | --- | 
| Pie | --- | Low | High| 
| --- | --- | Low | --- | 

我想程序吐出：
（在一個範圍或一個MsgBox或任何東西，用戶需要寫下的數字）

High: 2 
Low: 7 
Pie: 1 

我已經試過：
我使用CountIF功能嘗試過，但一直有figurin問題正確地輸出。
我有超過800行來測試，所以我想避免在簡單的循環中遍歷每一行。

加分點：
（我很高興與答案就在上面，但如果有人能想出解決辦法也將不勝感激）
有哪些組成muliple的某些單元格的值一個單詞的實例或者甚至多個單詞。
例如，少數細胞含有

Low 
Low 

僅通過一個回車分離。 甚至有在這當月一個單元包含

Low 
Low 
High 
Low 
Low 

我也想計數細胞內的每一次出現，因此上述電池會給輸出：

High: 1 
Low: 4 

Answer 1

試試這個：

Sub tgr() 

    Dim cllUnq As Collection 
    Dim rngCheck As Range 
    Dim CheckCell As Range 
    Dim arrUnq(1 To 65000) As String 
    Dim arrCount(1 To 65000) As Long 
    Dim varWord As Variant 
    Dim MatchIndex As Long 
    Dim lUnqCount As Long 

    On Error Resume Next 
    Set rngCheck = Application.InputBox("Select the cells containing strings to be counted", "Select Range", Selection.Address, Type:=8) 
    On Error GoTo 0 
    If rngCheck Is Nothing Then Exit Sub 'Pressed cancel 

    Set cllUnq = New Collection 

    For Each CheckCell In rngCheck.Cells 
     For Each varWord In Split(CheckCell.Text, Chr(10)) 
      If Len(Trim(varWord)) > 0 Then 
       On Error Resume Next 
       cllUnq.Add varWord, varWord 
       On Error GoTo 0 
       If cllUnq.Count > lUnqCount Then 
        lUnqCount = cllUnq.Count 
        arrUnq(lUnqCount) = CStr(varWord) 
        arrCount(lUnqCount) = 1 
       Else 
        MatchIndex = WorksheetFunction.Match(CStr(varWord), arrUnq, 0) 
        arrCount(MatchIndex) = arrCount(MatchIndex) + 1 
       End If 
      End If 
     Next varWord 
    Next CheckCell 

    If lUnqCount > 0 Then 
     Sheets.Add After:=Sheets(Sheets.Count) 
     With Range("A1:B1") 
      .Value = Array("Word", "Count") 
      .Font.Bold = True 
      .Borders(xlEdgeBottom).LineStyle = xlContinuous 
     End With 
     Range("A2").Resize(lUnqCount).Value = Application.Transpose(arrUnq) 
     Range("B2").Resize(lUnqCount).Value = Application.Transpose(arrCount) 
    End If 

    Set cllUnq = Nothing 
    Set rngCheck = Nothing 
    Set CheckCell = Nothing 
    Erase arrUnq 
    Erase arrCount 

End Sub 

Answer 2

嘗試。找到方法。轉到您的VBA幫助，查找range.find方法以獲得更多信息 - 它還提供了一些您應該可以輕鬆修改的代碼。
我會建議使用一個計數器，每次你有一個找到更新的每個值。例如：

Dim Low_count As Long 
Low_count = 0 
With Worksheets(1).Range("a1:a500") 
Set c = .Find("Low", LookIn:=xlValues) 
If Not c Is Nothing Then 
    firstAddress = c.Address 
    Do 
    Low_count = Low_count + 1 
    Set c = .FindNext(c) 
    Loop While Not c Is Nothing And c.Address <> firstAddress 
End If 
End With