VBA100本ノック13本目

vba_knock013.bas.vba

Option Explicit

'#VBA100本ノック 13本目
'選択セル（Selection:複数範囲あり）の文字列に「注意」という文字があった場合は、
'その「注意」の文字だけを"赤の太字"に設定してください。
'セル以外（図形等）が選択されている場合は何もせずに正常終了するようにしてください。

'※一部仕様を無視
'　図形選択前に選択していたセルを使ってでも絶対に処理を実行する
Sub vba_knock013()
    Call MarkupString(Excel.ActiveWindow.RangeSelection, "注意", vbRed, True)
End Sub

Rem セルに含まれる特定の文字列に書式設定を適用する
Rem  @param Cell     任意のセル範囲
Rem  @param findStr  検索文字列
Rem  @param nRGB     カラーコード
Rem  @param isBold   太字にするか
Sub MarkupString(ByVal Cell As Range, findStr As String, nRGB As Long, isBold As Boolean)
    If Cell Is Nothing Then Exit Sub
    
    '複数セルの場合はセルごとに再帰
    If Cell.CountLarge > 1 Then
        Set Cell = Intersect(Cell.Worksheet.UsedRange, Cell)
        If Cell Is Nothing Then Exit Sub
        
        Dim rng As Range
        For Each rng In Cell.Cells
            Call MarkupString(rng, findStr, nRGB, isBold)
        Next
        
        Exit Sub
    End If
    
    '空欄・数式・エラー・数値は処理しない
    If IsEmpty(Cell.Value) Then Exit Sub
    If Cell.HasFormula Or IsError(Cell.Value) Then Exit Sub
    If VarType(Cell.Value) = vbDouble Then Exit Sub
    
    '処理本体
    Dim txt As String::: txt = Cell.Value
    Dim nowPos As Long:: nowPos = 0
    Dim findPos As Long: findPos = 0
    Do
        findPos = InStr(nowPos + 1, txt, findStr, vbBinaryCompare)
        If findPos = 0 Then Exit Do
        
        With Cell.Characters(findPos, Len(findStr)).Font
            .Bold = isBold
            .Color = nRGB
        End With
        
        nowPos = findPos
    Loop
        
End Sub

'シート全体の"注意"着色テスト
Sub Test_MarkupString()
    Call Clear_Markup
    Call MarkupString(Excel.ActiveSheet.UsedRange, "注意", vbRed, True)
End Sub

Sub Clear_Markup()
    With Excel.ActiveSheet.UsedRange.Font
        .Bold = False
        .Color = 0
    End With
End Sub

元ネタ

https://twitter.com/yamaoka_ss/status/1322396623629033473?s=20

Twiter投稿

https://twitter.com/KotorinChunChun/status/1322806302582562816?s=20