発熱するマイナー魂

隠れた名作の発掘が生きがい。サブカル作品の感想とIT技術メモ中心のブログです。

【VBA】Excelファイルから赤色の文字を抽出する


スポンサードリンク

Excelで仕様書とか設計書を書いていると、修正した文字を赤色等で色付けしていたりします。ということは、修正箇所を把握するためには赤色の文字を抽出すれば良さそうです。そんな背景により、EXCELファイルから赤色文字を抽出するVBAのサンプルマクロを書きました。

f:id:yosinoo:20160113222843p:plain


サンプルマクロ

Option Explicit

Sub ExtractHighlightChars()
    ' チェック対象の文字色
    Dim CHECK_COLOR As Long
    CHECK_COLOR = 255 ' 赤
   
    ' 入力ファイル
    Dim inputFile As String
    inputFile = "C:\work\sample.xlsx"
   
    ' 対象文字色に一致した文字の配列
    Dim extractedChars() As String
    Dim charsCount As Long
    charsCount = 0
   
    ' ファイルオープン
    Application.ScreenUpdating = False
    Dim inputBook As Workbook
    Set inputBook = Workbooks.Open(inputFile, ReadOnly:=True)
   
    ' シート数分繰り返し
    Dim i As Long
    For i = 1 To inputBook.Worksheets.Count
       
        ' 列の最大値(16384)分繰り返し
        Dim j As Long
        For j = 1 To Columns.Count '本来
           
            ' 行の最大値(1048576)は大きいので、各列の最後のセルまでを繰り返し
            Dim k As Long
            For k = 1 To inputBook.Worksheets(i).Cells(Rows.Count, j).End(xlUp).Row
           
                ' チェック中のフラグ
                Dim isMatch As Boolean
                isMatch = False
               
                ' 文字数分繰り返し
                Dim l As Long
                For l = 1 To Len(inputBook.Worksheets(i).Cells(k, j))
               
                    ' チェック対象の文字色に一致するかどうか
                    If inputBook.Worksheets(i).Cells(k, j).Characters(Start:=l, Length:=1).Font.Color = CHECK_COLOR Then
                       
                        ' まだチェック中でなければ配列の要素数を増やす
                        If isMatch = False Then
                            charsCount = charsCount + 1
                            ReDim Preserve extractedChars(charsCount - 1)
                            isMatch = True
                        End If
                        extractedChars(charsCount - 1) = extractedChars(charsCount - 1) + Mid(inputBook.Worksheets(i).Cells(k, j).text, l, 1)
                    Else
                        isMatch = False
                    End If
                   
                Next l
            Next k
        Next j
    Next i
   
    ' 出力
    Dim p As Long
    For p = 0 To UBound(extractedChars)
        Debug.Print (extractedChars(p))
    Next p
   
    ' ファイルクローズ
    inputBook.Close SaveChanges:=False
    Set inputBook = Nothing
    Application.ScreenUpdating = True
   
End Sub


CHECK_COLORに赤色の文字を指定しています。色はRGB関数に従った値です。RGB関数では下記のような計算を行っています。赤だとredが255でRGB関数の結果も255、青だとblueが255でRGB関数の結果は16711680です。

RGB(red, green, blue) = red + green * 256 + blue * 256 * 256


シート、列、行、文字列の順でループ処理をネストしています。文字列の部分では、文字を一文字ずつ調べ、その文字のFont.ColorがCHECK_COLORと一致するかを調べています。一致するのであれば、その文字をつなげて動的配列に格納しています。


赤文字を黒文字に一括置換する処理も書きたかったのですが、単純に~.Font.Color=0で上書きするといった処理をすると、おそらくExcelの書式を壊してしまうみたいで、ファイルの内容が消えてしまうケースもありました。置換は1つずつ行った方が良いのかもしれない。