CountWords

' CountWords
' -----------------
' Macro Name: CountWords
' Description: 選択範囲のテキストの単語数をカウントする
' Parameters: なし
' Returns: なし
' Usage: 単語数をカウントするテキストが含まれるセル範囲を選択して実行
' -----------------

Sub CountWords()
    Dim cell As Range
    Dim resultWs As Worksheet
    Dim outputRow As Long
    Dim totalWords As Long
    Dim cellWords As Long

    On Error GoTo ErrorHandler

    If TypeName(Selection) <> "Range" Then
        MsgBox "セル範囲を選択してください。", vbExclamation
        Exit Sub
    End If

    Set resultWs = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    resultWs.Name = "単語数_" & Format(Now, "hhnnss")

    resultWs.Cells(1, 1).Value = "単語数カウント結果"
    resultWs.Cells(1, 1).Font.Bold = True
    resultWs.Cells(1, 1).Font.Size = 14

    resultWs.Cells(3, 1).Value = "セル"
    resultWs.Cells(3, 2).Value = "テキスト"
    resultWs.Cells(3, 3).Value = "単語数"
    resultWs.Cells(3, 1).Font.Bold = True
    resultWs.Cells(3, 2).Font.Bold = True
    resultWs.Cells(3, 3).Font.Bold = True
    resultWs.Range(resultWs.Cells(3, 1), resultWs.Cells(3, 3)).Interior.Color = RGB(200, 200, 200)

    outputRow = 4
    totalWords = 0

    For Each cell In Selection
        If cell.Value <> "" Then
            Dim text As String
            Dim words() As String
            text = CStr(cell.Value)
            words = Split(Trim(text))
            cellWords = 0
            Dim i As Long
            For i = LBound(words) To UBound(words)
                If words(i) <> "" Then
                    cellWords = cellWords + 1
                End If
            Next i

            resultWs.Cells(outputRow, 1).Value = cell.Address
            resultWs.Cells(outputRow, 2).Value = Left(text, 50) & IIf(Len(text) > 50, "...", "")
            resultWs.Cells(outputRow, 3).Value = cellWords
            resultWs.Cells(outputRow, 3).Font.Bold = True
            totalWords = totalWords + cellWords
            outputRow = outputRow + 1
        End If
    Next cell

    resultWs.Cells(outputRow + 1, 1).Value = "合計単語数:"
    resultWs.Cells(outputRow + 1, 1).Font.Bold = True
    resultWs.Cells(outputRow + 1, 3).Value = totalWords
    resultWs.Cells(outputRow + 1, 3).Font.Bold = True

    resultWs.Columns("A:C").AutoFit
    resultWs.Select

    MsgBox "単語数カウント完了: 合計 " & totalWords & " 語", vbInformation
    Exit Sub

ErrorHandler:
    MsgBox "エラーが発生しました: " & Err.Description, vbCritical
End Sub