求助：用Excel循环统计H列各值出现次数并写入Statistik工作表

Hey there! I feel your pain—writing 28 separate code blocks for each unique value is not just tedious, it's also a nightmare to maintain if new values pop up later. Let's use a dictionary object (a total lifesaver for unique value counting) to automate this entirely with loops. Here's a clean, scalable solution:

Step-by-Step Explanation & Code #

This code will:

• Automatically collect all unique values from Column H
• Count how many times each value appears
• Create or reuse the "Statistik" sheet to write results
• Handle empty cells and optional case sensitivity

Sub CountUniqueValuesInH()
    Dim wsSource As Worksheet
    Dim wsStats As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim valueDict As Object
    Dim key As Variant
    Dim outputRow As Long
    
    ' Define your source worksheet (change to your sheet name if needed, e.g., "Data")
    Set wsSource = ActiveSheet
    ' Check if "Statistik" exists—create it if not
    On Error Resume Next
    Set wsStats = ThisWorkbook.Worksheets("Statistik")
    On Error GoTo 0
    If wsStats Is Nothing Then
        Set wsStats = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsStats.Name = "Statistik"
    End If
    
    ' Initialize the dictionary to track unique values and counts
    Set valueDict = CreateObject("Scripting.Dictionary")
    valueDict.CompareMode = vbTextCompare ' Remove this line if you need case-sensitive counting
    
    ' Find the last used row in Column H
    lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row
    
    ' Loop through every cell in Column H (skip header row H1—adjust if your header is elsewhere)
    For Each cell In wsSource.Range("H2:H" & lastRow)
        If Not IsEmpty(cell.Value) Then ' Skip blank cells to avoid counting empty values
            ' Update dictionary: add new value with count 1, or increment count if it exists
            If valueDict.Exists(cell.Value) Then
                valueDict(cell.Value) = valueDict(cell.Value) + 1
            Else
                valueDict.Add cell.Value, 1
            End If
        End If
    Next cell
    
    ' Prepare the Statistik sheet for results
    wsStats.Cells.Clear ' Optional: clear old data before writing new results
    wsStats.Range("A1").Value = "唯一值"
    wsStats.Range("B1").Value = "出现次数"
    outputRow = 2 ' Start writing data from row 2 (below header)
    
    ' Loop through the dictionary to write results
    For Each key In valueDict.Keys
        wsStats.Range("A" & outputRow).Value = key
        wsStats.Range("B" & outputRow).Value = valueDict(key)
        outputRow = outputRow + 1
    Next key
    
    ' Quick formatting for readability (optional)
    wsStats.Range("A1:B1").Font.Bold = True
    wsStats.Columns("A:B").AutoFit
    
    ' Clean up objects
    Set valueDict = Nothing
    Set wsSource = Nothing
    Set wsStats = Nothing
    
    MsgBox "统计完成！结果已写入Statistik工作表。", vbInformation
End Sub

Key Notes for Customization #

• Source Sheet: If your data isn't on the active sheet, replace ActiveSheet with your sheet name (e.g., Set wsSource = ThisWorkbook.Worksheets("MyDataSheet")).
• Header Row: If your Column H doesn't have a header, change the range from H2:H" & lastRow to H1:H" & lastRow.
• Case Sensitivity: Remove the valueDict.CompareMode = vbTextCompare line if you need to treat "Apple" and "apple" as different values.
• Clear Old Data: If you don't want to overwrite previous results in Statistik, delete the wsStats.Cells.Clear line.

This solution will handle any number of unique values (not just 28) and automatically adapt if new values are added to Column H later—no more manual code updates!

内容的提问来源于stack exchange，提问作者RHS