【エクセルVBA】指定列で指定文字列を含む、セル個数を集計するVBA

あのー、ExcelのVBAで、指定列で指定文字列を含む、セルの個数を集計するコードは分かりますか？？

はい、可能ですよ。

本当ですか、教えてほしいです！！

サンプルコードをご紹介しましょう！

Excelの指定列で指定文字列を含む、セル個数を集計するコードをご紹介します。

マクロ機能が有効なExcelブック「.xlsm」を作成

Excelブック「.xlsm」の作成方法が不明な場合は、下記の記事を参考にして下さい。
【エクセルVBA】マクロ機能が有効なExcelブック「.xlsm」の作り方

コードを標準モジュールに貼り付け

標準モジュールの開き方が不明な場合は、下記の記事を参考にして下さい。
【エクセルVBA】標準モジュールの開き方

標準モジュールを開いて、下記のコードを貼り付けて下さい。

コード

指定列で指定文字列を含む、セルの個数を集計する

Sub SearchAndCountOccurrences()
    Dim ws As Worksheet
    Dim resultSheet As Worksheet
    Dim searchStr As String
    Dim count As Long
    Dim lastRow As Long
    Dim lastCol As Long
    Dim searchCol As Long
    Dim headerCell As Range
    Dim resultRow As Long
    Dim resultMessage As String ' メッセージを格納する変数
    Dim anyNonZero As Boolean ' 結果がゼロ以外の検索文字列があったかどうか
    
    ' 集計結果シートが存在しない場合、作成する
    On Error Resume Next
    Set resultSheet = ThisWorkbook.Sheets("集計結果")
    On Error GoTo 0
    
    If resultSheet Is Nothing Then
        ' 集計結果シートが存在しない場合、新たに作成
        Set resultSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))
        resultSheet.Name = "集計結果"
        
        ' A1セルに「検索文字列」、B1セルに「個数」と入力
        resultSheet.Cells(1, 1).Value = "検索文字列"
        resultSheet.Cells(1, 2).Value = "個数"
        
        ' A2セルに「検索希望の文字列を入力して下さい。」とメッセージを表示
        resultSheet.Cells(2, 1).Value = "A2セル以降に検索希望の文字列を入力して下さい。"
        
        ' メッセージを表示
        MsgBox "シート「集計結果」が存在しなかったため、新しく作成しました。" & vbCrLf & _
               "A2セル以降に検索文字列を入力してから、再度マクロを実行してください。"
        Exit Sub
    End If
    
    ' アクティブなシートを設定
    Set ws = ActiveSheet
    
    ' 集計結果シートのB列をクリア（古いカウント結果を削除）
    resultSheet.Range("B2:B" & resultSheet.Cells(resultSheet.Rows.count, 1).End(xlUp).Row).ClearContents
    
    ' 集計結果シートのA2セル以降に記載された検索文字列を順に処理
    resultRow = 2 ' 結果記入をB2セルから開始
    resultMessage = "" ' メッセージの初期値を空に設定
    anyNonZero = False ' 結果がゼロ以外の検索文字列があったかどうか
    
    ' アクティブシートの1行目（ヘッダー行）を取得
    lastCol = ws.Cells(1, ws.Columns.count).End(xlToLeft).Column
    
    ' 集計結果シートのA2セル以降に記載された検索文字列を順に処理
    Do While resultSheet.Cells(resultRow, 1).Value <> ""
        searchStr = resultSheet.Cells(resultRow, 1).Value
        
        ' 検索する文字列が空でないか確認
        If searchStr = "" Then
            MsgBox "検索する文字列が空です。"
            Exit Sub
        End If
        
        ' 1行目で検索文字列に一致する列を検索
        searchCol = 0
        For Each headerCell In ws.Range(ws.Cells(1, 1), ws.Cells(1, lastCol))
            If headerCell.Value = searchStr Then
                searchCol = headerCell.Column
                Exit For
            End If
        Next headerCell
        
        ' 検索文字列が見つからなかった場合
        If searchCol = 0 Then
            resultSheet.Cells(resultRow, 2).Value = "該当列なし"
            resultMessage = resultMessage & "検索文字列 """ & searchStr & """ : 該当列なし。" & vbCrLf
        Else
            ' 検索対象の列のデータ範囲を取得
            lastRow = ws.Cells(ws.Rows.count, searchCol).End(xlUp).Row
            
            ' 該当列にある「〇」の個数をカウント
            count = 0
            For i = 2 To lastRow ' 2行目から最終行まで調べる
                If ws.Cells(i, searchCol).Value = "〇" Then
                    count = count + 1
                End If
            Next i
            
            ' 結果を「集計結果」シートに記載
            resultSheet.Cells(resultRow, 2).Value = count
            
            ' もしカウントがゼロでない場合、anyNonZeroをTrueに設定し、メッセージに追加
            If count > 0 Then
                anyNonZero = True
                resultMessage = resultMessage & "検索文字列 """ & searchStr & """ : " & count & " 回" & vbCrLf
            Else
                resultMessage = resultMessage & "検索文字列 """ & searchStr & """ : 0 回" & vbCrLf
            End If
        End If
        
        ' 次の行へ進む
        resultRow = resultRow + 1
    Loop
    
    ' 結果がゼロ以外の検索文字列があった場合、メッセージを表示
    If anyNonZero Then
        MsgBox "検索が完了しました。" & vbCrLf & resultMessage
    Else
        ' 全ての結果がゼロの場合、特別なメッセージを表示
        MsgBox "検索文字列の検索結果は全て0個でした。"
    End If
End Sub

100

101

102

103

104

105

106

107

108

109

Sub SearchAndCountOccurrences()

Dim ws As Worksheet

Dim resultSheet As Worksheet

Dim searchStr As String

Dim count As Long

Dim lastRow As Long

Dim lastCol As Long

Dim searchCol As Long

Dim headerCell As Range

Dim resultRow As Long

Dim resultMessage As String ' メッセージを格納する変数

Dim anyNonZero As Boolean ' 結果がゼロ以外の検索文字列があったかどうか

' 集計結果シートが存在しない場合、作成する

On Error Resume Next

Set resultSheet = ThisWorkbook.Sheets("集計結果")

On Error GoTo 0

If resultSheet Is Nothing Then

' 集計結果シートが存在しない場合、新たに作成

Set resultSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.count))

resultSheet.Name = "集計結果"

' A1セルに「検索文字列」、B1セルに「個数」と入力

resultSheet.Cells(1, 1).Value = "検索文字列"

resultSheet.Cells(1, 2).Value = "個数"

' A2セルに「検索希望の文字列を入力して下さい。」とメッセージを表示

resultSheet.Cells(2, 1).Value = "A2セル以降に検索希望の文字列を入力して下さい。"

' メッセージを表示

MsgBox "シート「集計結果」が存在しなかったため、新しく作成しました。" & vbCrLf & _

"A2セル以降に検索文字列を入力してから、再度マクロを実行してください。"

Exit Sub

End If

' アクティブなシートを設定

Set ws = ActiveSheet

' 集計結果シートのB列をクリア（古いカウント結果を削除）

resultSheet.Range("B2:B" & resultSheet.Cells(resultSheet.Rows.count, 1).End(xlUp).Row).ClearContents

' 集計結果シートのA2セル以降に記載された検索文字列を順に処理

resultRow = 2 ' 結果記入をB2セルから開始

resultMessage = "" ' メッセージの初期値を空に設定

anyNonZero = False ' 結果がゼロ以外の検索文字列があったかどうか

' アクティブシートの1行目（ヘッダー行）を取得

lastCol = ws.Cells(1, ws.Columns.count).End(xlToLeft).Column

' 集計結果シートのA2セル以降に記載された検索文字列を順に処理

Do While resultSheet.Cells(resultRow, 1).Value <> ""

searchStr = resultSheet.Cells(resultRow, 1).Value

' 検索する文字列が空でないか確認

If searchStr = "" Then

MsgBox "検索する文字列が空です。"

Exit Sub

End If

' 1行目で検索文字列に一致する列を検索

searchCol = 0

For Each headerCell In ws.Range(ws.Cells(1, 1), ws.Cells(1, lastCol))

If headerCell.Value = searchStr Then

searchCol = headerCell.Column

Exit For

End If

Next headerCell

' 検索文字列が見つからなかった場合

If searchCol = 0 Then

resultSheet.Cells(resultRow, 2).Value = "該当列なし"

resultMessage = resultMessage & "検索文字列 """ & searchStr & """ : 該当列なし。" & vbCrLf

Else

' 検索対象の列のデータ範囲を取得

lastRow = ws.Cells(ws.Rows.count, searchCol).End(xlUp).Row

' 該当列にある「〇」の個数をカウント

count = 0

For i = 2 To lastRow ' 2行目から最終行まで調べる

If ws.Cells(i, searchCol).Value = "〇" Then

count = count + 1

End If

Next i

' 結果を「集計結果」シートに記載

resultSheet.Cells(resultRow, 2).Value = count

' もしカウントがゼロでない場合、anyNonZeroをTrueに設定し、メッセージに追加

If count > 0 Then

anyNonZero = True

resultMessage = resultMessage & "検索文字列 """ & searchStr & """ : " & count & " 回" & vbCrLf

Else

resultMessage = resultMessage & "検索文字列 """ & searchStr & """ : 0 回" & vbCrLf

End If

' 次の行へ進む

resultRow = resultRow + 1

Loop

' 結果がゼロ以外の検索文字列があった場合、メッセージを表示

If anyNonZero Then

MsgBox "検索が完了しました。" & vbCrLf & resultMessage

Else

' 全ての結果がゼロの場合、特別なメッセージを表示

MsgBox "検索文字列の検索結果は全て0個でした。"

End If

End Sub

マクロを実行

上記で作成したマクロファイル（ここでは「指定列で指定文字列を含む、セル個数を集計する.xlsm」とファイル名を設定。）を準備します。

マクロファイルを開いて、「コンテンツの有効化」をクリックします。
※設定により、「コンテンツの有効化」は表示されない（クリック不要の）場合もあります。

本ファイルの初期設定ではシートは「Sheet1」のみ存在しています。
また、予め下記の様に入力しています。

「開発」タブ、「マクロ」の順にクリックします。

マクロ「SearchAndCountOccurrences」を選択、「実行」をクリックします。

マクロが実行され、ウィンドウが表示されるので、「OK」をクリックします。

シート「集計結果」が作成されます。
A1、A2、B1セルに入力されます。

A2セル以降に、検索したいシート「Sheet1」の1行目に入力されている文字列を入力します。

シート「Sheet1」を選択します。

マクロ「SearchAndCountOccurrences」を選択、「実行」をクリックします。

マクロが実行され、ウィンドウが表示されます。
集計結果が表示されるので、確認して「OK」をクリックします。

シート「集計結果」を開くと、B列に集計結果が入力されます。

完了です。

検索する指定文字列が存在しない場合

シート「Sheet1」に存在しない文字列をA列に入力します。

マクロを実行すると、「該当列なし」と表示されます。

シート「集計結果」のB列に「該当列なし」と入力されます。

参考サイト

ChatGPTを活用して、修正を加えてコードを作成しました。