[엑셀 VBA] 특정 글자만 찾아 색상 바꾸기

엑셀의 바꾸기 기능을 이용해 서식을 변경할 수 있지만, 셀 내용의 일부분만 글꼴 색을 변경할 수는 없다. VBA를 이용해 사용자가 선택한 범위 또는 전체 워크시트 범위를 대상으로, 특정 글자만 찾아 글자 색상을 변경할 수 있다.

■  특정 글자만 찾아 색상 바꾸기

※ 아래 예제는 엑사모 latinum님이 만든 소스입니다. 

제가 필요에 의해서 블로그에 정리하는 차원에서 올린소스이니 착오없으시길 바랍니다. 

Option Explicit
'***************************************
'특정 글자 찾아서 색상을 변경하기
'엑셀의 모든 것 - MagcicSheet & 엑사모
'만든이: 황기성
'***************************************
Const Es As String = "MagicSheet & 엑사모"
Sub dhReplaceFontColor()
Dim strFind As String
Dim strAddress As String
Dim rngData As Range
Dim rngFind As Range
 '작업 범위
   Set rngData = dhWorkRange
   If rngData Is Nothing Then Exit Sub
   '찾을 글자
   strFind = InputBox("찾아서 글자의 색상을 바꿀 단어를 입력하십시오!", Es)
   If Len(strFind) = 0 Then Exit Sub
   
   Set rngFind = rngData.Find(what:=strFind, LookIn:=xlValues, lookat:=xlPart)
   
   If rngFind Is Nothing Then
       MsgBox "검색 단어가 없습니다!", vbExclamation, Es
   Else
       '첫번째 찾은 셀의 주소를 변수에 담는다
       strAddress = rngFind.Address
       Do
           'dhFontColorChange를 이용해 글꼴의 색상을 변경
           dhFontColorChange rngFind, strFind
           Set rngFind = rngData.FindNext(rngFind)
       Loop While strAddress <> rngFind.Address '모두 찾을 때까지 순환
   End If
End Sub
Private Sub dhFontColorChange(rngL As Range, strFind As String, Optional lngFontColor As Long = vbRed)
Dim intStart As Integer
Dim intFlen As Integer
Dim strTemp As String
Dim i As Integer
Dim k As Integer
Dim intR As Integer
   k = 1
   With rngL
       '바꿀 문자열의 길이
       intFlen = Len(strFind)
       strTemp = .Value
       '찾는 단어가 몇 개가 있는지 확인 - 97과 같은 하위버전에서는 Replace 함수가 없으므로
       '엑셀 내장함수인 Substitute를 사용해 아래와 같이 한다
       'intR = (Len(strTemp) - _
           Len(Application.WorksheetFunction. _
           Substitute(UCase(strTemp), UCase(strFind), ""))) / intFlen
       '대소문자를 비교하지 않기 위해서 Ucase 함수를 사용
       intR = (Len(strTemp) - Len(Replace( _
               UCase(strTemp), UCase(strFind), ""))) / intFlen
   
       For i = 1 To intR
           '대소문자를 구분하지 않고 비교한다
           intStart = InStr(k, strTemp, strFind, vbTextCompare)
           If intStart = 0 Then
               Exit For
           Else
               'k = k + intStart + 1 '다음 찾을 위치
               k = intFlen + intStart  '다음 찾을 위치 버그 수정
               '찾는 문자의 글꼴의 색상을 사용자가 바꾸려고 하는 색(기본 값은 붉은 색)으로 변경
               .Characters(intStart, intFlen).Font.Color = lngFontColor 'vbRed
           End If
       Next i
   End With
End Sub
Private Function dhWorkRange(Optional blnMulti As Boolean = False) As Range
'**************************************
'작업 범위를 구하는 사용자 정의 함수
'**************************************
       If TypeName(Selection) = "Range" Then '워크시트 범위를 선택했는가
           If Selection.Cells.Count = 1 Then '셀 하나만 선택한 경우
               'If Selection.CurrentRegion.Cells.Count = 1 Then
                   Set dhWorkRange = ActiveSheet.UsedRange '워크시트 전체를 범위로
               'Else
               '    Set dhWorkRange = Selection.CurrentRegion '현재 셀이 있는 영역
               'End If
           Else
               Set dhWorkRange = Selection '선택한 영역만
               If blnMulti Then '여러범위 선택 가능한 경우
               Else
                   If dhWorkRange.Areas.Count = 1 Then
                   Else
                       '여러 범위를 선택해 작업할 수 없을 경우
                       MsgBox "여러 범위를 선택해 이 작업을 하실 수 없습니다!", _
                              vbExclamation, Es
                       Set dhWorkRange = Nothing
                   End If
               End If
           End If
       Else
           MsgBox "워크시트 범위를 선택하시고 이 작업을 하십시오!", vbExclamation, Es
           'End
       End If
End Function