ExcelVBAで特定の文字列を検索して、転記や書式変更する

ちょっと前にGoogleAnalyticsの検索結果を、複数指定した単語を全部抜き出して分析するExcelVBAを作ったんですが、そこで書いた検索（もどき）のコードを解説してみました。

概要

選択していない「data」という名前のシートに、文字列がA1から下にずらっと並んでいるとして、その中から指定した複数キーワードにひっかかるものだけをアクティブシート（「data」シートとは別）のA1から下へ転記していくというものです。冒頭で書いた分析は、これをベースにつくっています。

コード

Sub キーワード検索()
  Dim str As String, i As Integer, n As Integer, key(99) As String, flg As Boolean, end_r As Integer

  str = InputBox("キーワードを入力してください。") '入力要求
  If str = "" Then Exit Sub 'キャンセルなら終了

  str = StrConv(str, vbNarrow) '半角へ変換
  str = StrConv(str, vbLowerCase) '小文字へ変換

  Application.ScreenUpdating = False '画面非表示にて高速化

  Range("A1:A1000").ClearContents '前のデータをクリア

  n = 1 '判別用数初期値
  Do
    If InStr(str, " ") = 0 Then  'キーワード内にスペースが含まれていなかったら
      key(i) = str '最後のキーワードとして取得
      Exit Do '繰り返しを抜ける
    ElseIf Mid(str, n, 1) = " " Then 'キーワードのn番目の文字がスペースだったら
      key(i) = Left(str, n - 1) 'スペースより左側をひとつのキーワードとして取得
      str = Right(str, Len(str) - n) 'スペースより右側を上書き
      i = i + 1 'キーワード用配列を+1
      n = 0 '判別用数値リセット
    End If
    n = n + 1 '判別用数値+1
  Loop

  With Sheets("data") '"data"シートをWithで省略
    i = 1 '転記前行数用
    end_r = 1 '転記後行数用
    Do
      n = 0 '入力したkey用数値リセット
      flg = False 'フラグをオフにしておく
      str = .Cells(i, 1) '値を取得
      str = StrConv(str, vbNarrow) '半角へ変換
      str = StrConv(str, vbLowerCase) '小文字へ変換
      Do
        If InStr(str, key(n)) <> 0 Then '値の中にkeyが含まれていたら
          flg = True 'フラグを立てて
          Exit Do '繰り返しを抜ける
        End If
        n = n + 1 'nを+1して次のkeyへ
        If key(n) = "" Then Exit Do 'keyがなくなったら繰り返しを抜ける
      Loop
      If flg = True Then 'フラグが立っていたら（キーワードが合致していたら）
        .Cells(i, 1).Copy 'コピー
        Cells(end_r, 1).PasteSpecial Paste:=xlValues '値貼り付け
        end_r = end_r + 1
      End If
      i = i + 1 '行数を+1
      If .Cells(i, 1) = "" Then Exit Do '何もなくなったら終了
    Loop
  End With
  Application.CutCopyMode = False 'コピーモード解除
  Range("A1").Select 'A1セルをセレクト（貼り付けられたセルがセレクトされているので）

  Application.ScreenUpdating = True '画面表示をONにして高速化終了
End Sub

ちょっと長いですが、こんな感じで。コピペすればそのまま動くと思います。

解説

キーワードを分割して配列へ

まず一番最初の4行目でInputBoxへキーワードをユーザーに入力してもらいます。そのキーワードをとりあえずstrという変数にまるごと格納。

15～26行の中で、strをスペース毎に分割して、配列へひとつずつ入れていきます。まずは16行目で、str内にスペースが含まれているか判別します。

If InStr(str, " ") = 0 Then

ここでキーワードがひとつだった場合、又は全て分割されて、最後のひとつだった場合の処理をしています。キーワードを格納してDoを抜けます。

次に19行目、スペースが含まれていた場合です。ここで使っているのが、

If Mid(str, n, 1) = " " Then

です。strの左からn番目の文字をひとつずつ、スペースかどうか判別しています。スペースでなければnを+1して繰り返し。スペースが見つかったら左側をキーワードとして格納、右側をstrに上書き、という作業をしています。

イメージとしては、こんな感じ。これを繰り返すと最終的にスペースがなくなるので、先程の16行目からIf内に入っていってDoを抜けるという寸法です！

転記前の文字列と照らし合わせる

28～53行で、「data」というシートの文字列と、先ほど分割したキーワードをひとつずつ照合させて、ひとつでも含まれているものがあれば転記するということをしています。ここはそんなに難しくはないですね。

いかがでしたでしょうか。7,8,35,36行目で半角・小文字に変換してから照合することでそのあたりの検索バラつきには対応しております。スペースにも半角・全角あるので、ここは必須かも。結構ニッチな内容な気もしますが、どなたかのご参考にでもなれれば幸いですー。

追記

コメント欄にてリクエストを頂いたので、作ってみました。

行全てを転記する

こちらは、ほぼ上記のコードでいけるので、変更点のみ。46行目と47行目をこちらへ差し替えます。

.Rows(i).Copy 'コピー
Rows(end_r).PasteSpecial Paste:=xlValues '値貼り付け

こちらは値のみを貼り付けするので、文字色など書式もコピーしてきたい場合はPaste:=xlValuesを削除してください。

検索ヒットしたテキストだけを強調

こちらは転記ではなく、アクティブシート内のキーワードを太字・赤にします。

Sub キーワード検索()
  Dim str As String, i As Long, j As Long, n As Integer, key(99) As String
  Dim end_r As Long, end_c As Long, key_n As Long, str_wide As String
 
  str = InputBox("キーワードを入力してください。") '入力要求
  If str = "" Then Exit Sub 'キャンセルなら終了
  
  str = StrConv(str, vbNarrow) '半角へ変換
  str = StrConv(str, vbLowerCase) '小文字へ変換
 
  n = 1 '判別用数初期値
  Do
    If InStr(str, " ") = 0 Then  'キーワード内にスペースが含まれていなかったら
      key(i) = str '最後のキーワードとして格納
      str_wide = StrConv(key(i), vbWide) 'キーワードを全角にしてみる
      If Len(key(i)) <> Len(str_wide) Then '半角と全角の文字数が異なるなら
        key(i + 1) = str_wide '全角も格納
      End If
      Exit Do '繰り返しを抜ける
    ElseIf Mid(str, n, 1) = " " Then 'キーワードのn番目の文字がスペースだったら
      key(i) = Left(str, n - 1) 'スペースより左側をひとつのキーワードとして取得
      str_wide = StrConv(key(i), vbWide) 'キーワードを全角にしてみる
      If Len(key(i)) <> Len(str_wide) Then '半角と全角の文字数が異なるなら
        key(i + 1) = str_wide '全角も格納
        i = i + 1 'ひとつ増えたので
      End If
      str = Right(str, Len(str) - n) 'スペースより右側を上書き
      i = i + 1 'キーワード用配列を+1
      n = 0 '判別用数値リセット
    End If
    n = n + 1 '判別用数値+1
  Loop
  
  With Range("A1").SpecialCells(xlLastCell)
    end_r = .Row '使用セル範囲の最終行取得
    end_c = .Column '使用セル範囲の最終列取得
  End With
  
  With Range(Range("A1"), Cells(end_r, end_c)).Font 'フォントを初期化
    .Bold = False '太字解除
    .ColorIndex = xlAutomatic '自動色
  End With
  
  Application.ScreenUpdating = False '画面非表示にて高速化
  
  For i = 1 To end_r
    For j = 1 To end_c
      If Cells(i, j) <> "" Then 'セルが空白ならForを抜ける
        str = Cells(i, j) '値を取得
        str = StrConv(str, vbLowerCase) '小文字へ変換（※半角へはしない）
        For n = 0 To 100 'キーワードを繰り返す
          If key(n) = "" Then Exit For 'キーワードが空白になったらForを抜ける
          key_n = InStr(1, str, key(n)) 'キーワードの位置
          Do While key_n > 0 '文字列にキーワードが見つからなくなるまで
            With Cells(i, j).Characters(key_n, Len(key(n))).Font 'セル内の特定位置のみ
              .Bold = True '太字
              .ColorIndex = 3 '赤
            End With
            key_n = InStr(key_n + 1, str, key(n)) '同じセル内に複数ないかチェック
          Loop
        Next n 'キーワードのループ
      End If
    Next j '列のループ
  Next i '行のループ
  
  Application.ScreenUpdating = True '画面表示をONにして高速化終了
End Sub

セル内のキーワードのみ、太字や赤字にする方法はこちらを参考にさせていただきました

• エクセルVBAでセル内の特定文字列を太字に | OKWave

今回の肝は、「半角・全角や、小文字・大文字なども検出する」ということを前提に書いてきました。そのため、前述の転記するコードではキーワードと比較対象の両方を半角・小文字へ変換してから比較するという方法をとっています。これが、転記のときは単なるコピペだったので問題なかったのですが、セル内の特定文字を太字などにしたい場合、

Range("A1").Characters(先頭からの位置, 文字数).Font.Bold = True

という書き方になるようでして、対象文字列を半角へ変換したときに一部カタカナで文字数が変わってしまい、不具合が起こりました。

そのため、今回のコードでは、キーワードを配列化するときに半角と全角で文字数が違うものは両パターン格納しておき（16～18, 23～26行）、比較対象の文字列は小文字変換のみにして半角化は行わない（50行）、という方法をとることにしました。

と、いう感じでいかがでしょうか。これはわたしも仕事で使えそうです！teruさんありがとうございましたー！