セル内の一部文字に色を付けてみる(3)

 YouTubeに投稿した動画内で使用しているコードを貼っておきます。

ご参考までに。

エラー処理など、きちんと作りこんでいないので

コードをコピペして使用するのはオススメしません (m´・ω・｀)m ｺﾞﾒﾝ…

また、実行時の条件によってXMLの形式が破損し、Excelデータを紛失する可能性がありますので、コードの内容を理解したうえでご使用ください。

※コードは自己責任でご使用ください。

【動作条件】

• Module内にコードが記述されていること
• キーワードを指定したテーブル名は "キーワードリスト" になっていること
• キーワードが被っていないこと
• 選択している範囲は文字を入力しているセルだけになっていること
• 選択しているセルのCharactersオブジェクトにColor, Bold以外の設定がされていないこと
• その他、なんプロが気付いていない動作条件を満たしていないこと(´・ω・`)

Public Sub mainWithXml()
    
    Dim objTarget As Range
    Set objTarget = Selection
    
    '先にセル内の書式をリセットしておく'
    With objTarget.Font
        .Color = 0
        .Bold = False
    End With
    
    Dim objCell As Range
    Dim objRngGrp As Range
    
    '100セルずつ処理'
    For Each objCell In objTarget.Cells
        
        If objRngGrp Is Nothing Then                '1つ目のセル'
            Set objRngGrp = objCell
            
        ElseIf objRngGrp.Cells.Count <= 99 Then     '2～99個目のセル'
            Set objRngGrp = Application.Union(objRngGrp, objCell)
            
        Else                                        '100個目のセル'
            
            Set objRngGrp = Application.Union(objRngGrp, objCell)
            
            Call setColorWithXml(objRngGrp, Application.Range("キーワードリスト"))
            
            Set objRngGrp = Nothing
            
        End If
        
    Next
    
    '100個に満たなかった最後のセル'
    If Not objRngGrp Is Nothing Then
        
        Call setColorWithXml(objRngGrp, Application.Range("キーワードリスト"))
        
    End If
    
End Sub


'XMLレベルでセル内の文字色(&Bold)を設定するプロシージャ'
'検索文字列が重複している場合は正常動作しません'
Private Sub setColorWithXml(ByVal objRngGrp As Range, ByVal objRngFindString As Range)
    
    Const FONT_ST = "<Font html:Color=""#[COLOR]"">"
    Const FONT_ED = "</Font>"
    Const B_ST = "<B>"
    Const B_ED = "</B>"
    
    Dim objRng As Range
    Dim strXml As String
    
    'XMLデータ取得'
    strXml = objRngGrp.Value(XlRangeValueDataType.xlRangeValueXMLSpreadsheet)
    
    '先にData要素を置換（リテラル決め打ち）'
    strXml = Replace(strXml, "<Data ss:Type=""String"">", _
                             "<ss:Data ss:Type=""String"" xmlns=""http://www.w3.org/TR/REC-html40"">")
    strXml = Replace(strXml, "</Data>", "</ss:Data>")
    
    '検索文字分ループ'
    For Each objRng In objRngFindString.Cells
        
        Dim strRep As String
        Dim lngColor As Long
        
        'HTMLカラーに変換'
        With objRng.Font
            lngColor = (.Color And &HFF) * (2 ^ 16)
            lngColor = lngColor + (.Color And &HFF00&)
            lngColor = lngColor + ((.Color And &HFF0000) / (2 ^ 16))
        End With
        
        'タグ生成'
        strRep = Replace(FONT_ST, "[COLOR]", Right(String(6, "0") & Hex(lngColor), 6))
        If objRng.Font.Bold Then strRep = strRep & B_ST
        strRep = strRep & objRng.Value
        If objRng.Font.Bold Then strRep = strRep & B_ED
        strRep = strRep & FONT_ED
        
        '置換処理'
        strXml = Replace(strXml, objRng.Value, strRep)
        
    Next
    
    'XMLデータを書き戻す'
    objRngGrp.Value(XlRangeValueDataType.xlRangeValueXMLSpreadsheet) = strXml
    
End Sub