ここから本文です

vbaで半角英数字以外の文字に色を付けたいです。

アバター

ID非公開さん

2018/11/915:00:26

vbaで半角英数字以外の文字に色を付けたいです。

(セルにではなく、文字に色を付けたいです。)

下記のコードで、半角英字には青、半角数字には赤の色が付く事が確認できましたが、
半角英数字は黒のままで、
それ以外の全角英数字、漢字、記号に赤の色を付けたいのですが、
どうしたらいいでしょうか。

宜しくお願い致します。

——————————————-

Sub test()
Dim c As Range, myStr As String
Dim i As Integer
Application.ScreenUpdating = False

For Each c In Selection
For i = 1 To Len(c.Value)
myStr = StrConv(Mid(c.Value, i, 1), vbNarrow)

If myStr Like "[A-Z]" Then c.Characters(i, 1).Font.ColorIndex = 5
If myStr Like "[0-9]" Then c.Characters(i, 1).Font.ColorIndex = 3
Next i
Next

Application.ScreenUpdating = True
End Sub

閲覧数:
101
回答数:
3

違反報告

ベストアンサーに選ばれた回答

kik********さん

2018/11/1012:15:09

雰囲気、以下でどうなりますか

標準モジュールに以下を記述し Samp1 を実行してみます

確認用データが必要なら、範囲を選択後 testData を実行します


どうなりますか


Option Explicit

Public Sub Samp1()
   Dim r As Range
   Dim sS As String
   Dim i As Long, k As Long, n As Long
   Const CC As Long = 3 ' 色番号

   If (TypeName(Selection) <> "Range") Then Exit Sub

   Application.ScreenUpdating = False
   With Selection
      .Font.ColorIndex = xlAutomatic
      For Each r In .Cells
         If (VarType(r.Value) = vbString) Then
            sS = r.Value
            k = 0
            n = 0
            For i = 1 To Len(sS)
               If (Mid(sS, i, 1) Like "[!0-9A-Za-z]") Then
                  If (k = 0) Then
                     k = i
                     n = 1
                  ElseIf (i = k + 1) Then
                     n = n + 1
                  Else
                     r.Characters(k, n).Font.ColorIndex = CC
                     k = i
                     n = 1
                  End If
               End If
            Next
            If (k > 0) Then
               r.Characters(k, n).Font.ColorIndex = CC
            End If
         End If
      Next
   End With
   Application.ScreenUpdating = True
End Sub


' 確認用データ作成

Public Sub testData()
   Dim r As Range
   Dim sS As String
   Dim i As Long, k As Long
   Const CCW As Long = 15

   Randomize

   If (TypeName(Selection) <> "Range") Then Exit Sub

   Application.ScreenUpdating = False
   With Selection
      .Clear
      For Each r In .Cells
         Select Case Int(5 * Rnd())
            Case 0
            Case 1
               r.Value = Format(Date, "yyyy/mm/dd")
            Case 2
               r.Value = Int(100 * Rnd()) * 100
            Case Else
               sS = ""
               While (Len(sS) < CCW)
                  Select Case Int(6 * Rnd())
                     Case 0
                        sS = sS & Int(10 * Rnd())
                     Case 1
                        sS = sS & Chr(Asc("A") + Int(26 * Rnd()))
                     Case 2
                        sS = sS & Chr(Asc("a") + Int(26 * Rnd()))
                     Case 3
                        sS = sS & ChrW(AscW("A") + Int(26 * Rnd()))
                     Case Else
                        sS = sS & ChrW(AscW("あ") + Int(160 * Rnd()))
                  End Select
               Wend
               r.Value = sS
         End Select
      Next
      .EntireColumn.AutoFit
   End With
   Application.ScreenUpdating = True
End Sub

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

ベストアンサー以外の回答

1〜2件/2件中

並び替え:回答日時の
新しい順
|古い順

ina********さん

2018/11/915:50:02

こんな感じでいかがでしょうか。


Sub test()
    Dim c As Range, myStr As String
    Dim i As Integer
    
    For Each c In Intersect(Selection, ActiveSheet.UsedRange)
        For i = 1 To Len(c.Value)
            myStr = Mid(c.Value, i, 1)
            
            If 半角英数字(myStr) Then
                c.Characters(i, 1).Font.ColorIndex = xlColorIndexAutomatic
            Else
                c.Characters(i, 1).Font.Color = vbRed
            End If
        Next i
    Next
    
    Application.ScreenUpdating = True
End Sub


Function 半角英数字(S As String) As Boolean
    If S = "" Then 半角英数字 = False: Exit Function
    If S Like "*[!A-Za-z0-9]*" Then
        半角英数字 = False
    Else
        半角英数字 = True
    End If
End Function

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

yok********さん

2018/11/915:17:49

半角は黒ならどうして半角変換後しか見ないのですか?両方で判定しないとオリジナルが半角かどうかわからないのでは?

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

あわせて知りたい

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる