読者です 読者をやめる 読者になる 読者になる

発熱するマイナー魂

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

【VBA】効果の付いた文字を抽出する(太字/斜体/取り消し線)


スポンサードリンク

Excelに書かれたテキストを検索し、太字、斜体、取り消し線の効果が付けられた文字を抽出するサンプルマクロを書きました。


f:id:yosinoo:20160118223047p:plain:w400


文字の効果はFontオブジェクトのプロパティで設定することができ、太字、斜体、取り消し線は下記のようになっています。

(1) Font.Bold 太字
(2) Font.Italic 斜体
(3) Font.Strikethrough 取り消し線


プロパティ値がTrueであれば効果が設定されていることを示しており、それを利用してIf文で条件判定して文字を抽出します。下記は指定されたファイルから効果の付いた文字を抽出する関数です。

Option Explicit

' ファイルから効果の付いた文字を抽出し、配列に格納して返却する
Private Function ExtractEffectChars(ByVal inputfile As String) As String()
    ' ファイルオープン
    Application.ScreenUpdating = False
    Dim inputBook As Workbook
    Set inputBook = Workbooks.Open(inputfile, ReadOnly:=False)
   
    ' 効果のある文字の配列
    Dim extractedChars() As String
    Dim charsCount As Long
    charsCount = 0
   
    ' シート数分繰り返し
    Dim i As Long
    For i = 1 To inputBook.Worksheets.Count
       
        ' 列の最大値(16384)分繰り返し
        Dim j As Long
        For j = 1 To Columns.Count '本来
        'For j = 1 To 2
           
            ' 行の最大値(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.Bold = True Then ' (1) 太字
                    ' If inputBook.Worksheets(i).Cells(k, j).Characters(Start:=l, Length:=1).Font.Italic = True Then ' (2) 斜体
                    ' If inputBook.Worksheets(i).Cells(k, j).Characters(Start:=l, Length:=1).Font.Strikethrough = True Then ' (3) 取り消し線
                       
                        ' まだチェック中でなければ配列の要素数を増やす
                        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
   
    ' ファイルクローズ
    inputBook.Close SaveChanges:=True
    Set inputBook = Nothing
    Application.ScreenUpdating = True
   
    ' 抽出結果を返却
    ExtractEffectChars = extractedChars
   
End Function


【VBA】Excelファイルから赤色の文字を抽出するで書いたプログラムをベースにして関数化しました。