【エクセルマクロ】全角英数字記号に色付け：3倍高速化する手法

エクセルマクロで、全角英数字・全角記号に色を付けるVBAコードをご紹介します。

このページのマクロコードは、コピペで使えます。
ぜひ、お試しください。

全角英数字記号に色付け

以下のExcelVBAを実行すると、全角英数字記号の色を変えます。

Sub 全角英数字記号を着色()

  Dim myRange As Range
  Dim SearchArea As Range
  Dim FirstAddress As String
  Dim TempChar As String
  Dim InputWord() As Variant
  Dim i As Long
  Dim Q As Long
  Dim UsedRow As Long
  Dim UsedClm As Long
    
  '色付けしたい全角英数字を配列に格納
  InputWord = Array("，", "／", "［", "］", "｛", "｝", "＜", "＞", "￥", "・", "．", "＝", "：", "；", "＆", "％", "＿", "―", _
                    "０", "１", "２", "３", "４", "５", "６", "７", "８", "９", _
                    "ａ", "ｂ", "ｃ", "ｄ", "ｅ", "ｆ", "ｇ", "ｈ", "ｉ", "ｊ", "ｋ", "ｌ", "ｍ", "ｎ", "ｏ", "ｐ", "ｑ", "ｒ", "ｓ", "ｔ", "ｕ", "ｖ", "ｗ", "ｘ", "ｙ", "ｚ", _
                    "Ａ", "Ｂ", "Ｃ", "Ｄ", "Ｅ", "Ｆ", "Ｇ", "Ｈ", "Ｉ", "Ｊ", "Ｋ", "Ｌ", "Ｍ", "Ｎ", "Ｏ", "Ｐ", "Ｑ", "Ｒ", "Ｓ", "Ｔ", "Ｕ", "Ｖ", "Ｗ", "Ｘ", "Ｙ", "Ｚ")

  'データ入力エリアを取得
  With ActiveSheet.UsedRange
      UsedRow = .Rows(.Rows.Count).Row
      UsedClm = .Columns(.Columns.Count).Column
  End With

  'データ入力エリアを変数へ
  Set SearchArea = Range(Cells(1, 1), Cells(UsedRow, UsedClm))
    
  '配列をループ
  For Q = 0 To UBound(InputWord)
    
      '全角英数字を検索
      Set myRange = SearchArea.Find(What:=InputWord(Q), LookIn:=xlValues, _
                    LookAt:=xlPart, MatchCase:=True, MatchByte:=True)
    
      '全角英数字を含むセルがない場合
      If myRange Is Nothing Then
    
      '全角英数字を含むセルがある場合
      Else
    
        '最初に見つかったセル
        FirstAddress = myRange.Address
    
        Do
    
            'セルを1文字ずつループ
            For i = 1 To Len(myRange)
    
                '1文字ずつ変数へ
                TempChar = Mid(myRange, i, 1)
    
                '検索対象の全角英数字と一致しているか確認
                If TempChar = InputWord(Q) Then    
                  myRange.Characters(Start:=i, Length:=1).Font.ColorIndex = 3   
                End If
                    
            Next i
                
            '次を検索
            Set myRange = Cells.FindNext(myRange)
    
            If myRange Is Nothing Then Exit Do
    
        Loop While Not myRange Is Nothing And myRange.Address <> FirstAddress
  
      End If
  Next Q

  Set SearchArea = Nothing
  Set myRange = Nothing

End Sub

マクロ実行後

セル内の全角英数字・全角記号のみ色を付けました。

 
この記事がお役に立ちますと幸いです。
 
・【エクセルマクロ】色付けを自動化する使用例まとめ
 

【エクセルマクロ】色付け処理を自動化する：超便利32選

...

kirinote.com

2022.12.04