【エクセルマクロ】全角英数字記号に色付け: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(",", "/", "[", "]", "{", "}", "<", ">", "¥", "・", ".", "=", ":", ";", "&", "%", "_", "―", _
                    "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", _
                    "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", _
                    "A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")

  'データ入力エリアを取得
  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

 

マクロ実行後

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


 

【エクセルマクロ】数字のみ色をつける:馬鹿みたいに高速化
...