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