[VBA] 원본과 비교하여 같은 단어들을 강조해라

오늘도 같은 오픈 챗 크루중 한분의 질문으로 시작하여 구문을 작성하게 되었다..

아.SQL 공부해야 하는데

두번의 GG 선언도 필요없었다..

역시 엑사남님은 명강사가 맞다..

공부하기 싫어하는 학생을 어떻게는 자극하여 결국 공부를 하게 만드니....

코드 진행은 이렇다..

1. 두번의 정규식을 필요로 한다.

이유는 문장속에서 띄어쓰기와 언더바를 통해 각 단어들을 분리할것이다.

 

2. 분리된 단어들을 각 영역에 대입을 하여 단어들의 빈도수를 체크하게 될것이다.

 

3. 엑셀입니다 / 엑셀이라도 / 엑셀공부 / 엑셀   이렇게 있다고 하면

엑셀입니다(1) / 엑셀이라도(1) / 엑셀공부(1) / 엑셀(4) 이렇게 카운팅이 된다.

 

4. 결국 [엑셀]단어만 색상이 변경되게 된다.

 

* 정말 중요한 구문은 이렇다... 원본 필드와 비교 필드를 모두 결합한 후 패턴화 시키기 때문에 패턴 분리된 것이 중복값이 여러개여서 대상이 될 수 있지만 그게 원본 필드에는 없을 수도 있을 수도 있고 비교 필드에 있을 수도 없을 수도 있다. 따라서 영역에서 값이 변경이 되면 Findex값을 변경된 단어의 길이만큼 더해서 다음 중복단어를 찾게 되는데 그 영역에 더 이상 없으면 Findex값을 0을 반환하게 된다. 그 뜻은 해당 영역에는 같은 값이 없다는 뜻이기 때문에 Findex를 1로 변경하여야 한다.

  Findex = InStr(Findex, rngA, mat1(0), 1)  '= Findex값을 찾아라
  If Findex = 0 Then                '= 만일 Findex의 값이 0이면 / 패턴이 일치값은 2번이상이지만
     Findex = 1                     '= 해당 영역에 없다는 뜻이다.
  Else                              '= 패턴이 해당영역에 있다면
     With rngA.Characters(Findex, Len(mat1(0)))  '= 해당 위치의 단어들을
         .Font.Color = vbRed        '= 색상변경
         .Font.Bold = True          '= 굵기 강조
     End With

     Findex = Findex + Len(mat1(0)) '= 해당 영역에 중복값을 찾기 위해 Findex값 변경
 end if

완성된 구문은 아래와 같다.

Option Explicit
Sub Haja_Characters_Compare()

    Dim rngAll As Range, rngA As Range                  '= 순환문 변수
    Dim rngX As Range: Set rngX = [a2]                  '= [a2] 부터 시작
    Dim reg As Object, reg1 As Object                   '= 정규식 변수
    Dim mat As Object, mat1 As Object                   '= 정규식 일치 변수
    Dim i&, j&, Findex&: Findex = 1                     '= i: mat.count / j: mat1.count
    Dim Str                                             '= Findex : Characters문의 시작값
  
    With [a5].CurrentRegion
        .Font.Bold = False: .Font.Color = vbBlack       '= 초기화
    End With
    Set reg = Haja_Reg: Set reg1 = Haja_Reg             '= 정규식 선언
    
    Do Until rngX = ""                                  '= rngX의 값이 없을 때까지 / 원본 데이터가 있을 때까지 순환
    With reg                                            '= 정규식 패턴선언
        .Pattern = "([^\s\_]+)"                         '= 공백이나 언더바(_)가 없는 값을 패턴으로 해라
        .Global = True
    End With
    
    Str = rngX & " " & rngX.Next                        '= Str : 원본 필드와 비교 필드를 결합한 값을 str에 넣어라

    If reg.test(Str) Then                               '= 정규식 패턴에 일치하는 값이 있다면
    
        Set mat = reg.Execute(Str)                      '= Mat - 정규식의 패턴과 일치하는 값
        For Each rngA In Union(rngX, rngX.Next)         '= 각 행의 원본 필드와 비교 필드를 순환해라
             For i = 0 To mat.Count - 1                 '= 패턴과 일치하는 값만큼 순환해라
             
                 With reg1                              '= 첫 정규식으로 걸러낸 패턴들 중
                     .Pattern = mat(i)                  '= 하나씩 두번째 정규식의 패턴으로 넣어라
                     .Global = True
                 End With
                 
                 Set mat1 = reg1.Execute(Str)           '= 두번째 정규식과 일치된 값들을 Mat1에 넣어라
              
                 If mat1.Count > 1 Then                 '= 영역에서 해당 패턴이 두번이상 반복된다면
                 For j = 0 To mat1.Count - 1            '= 두번이상 반복된 Mat1값을 순환해라
                 On Error Resume Next                   '= 일치값이 없으면 에러나는 것을 무시해라
                      Findex = InStr(Findex, rngA, mat1(0), 1)  '= Findex값을 찾아라
                      If Findex = 0 Then                '= 만일 Findex의 값이 0이면 / 패턴이 일치값은 2번이상이지만
                         Findex = 1                     '= 해당 영역에 없다는 뜻이다.
                      Else                              '= 패턴이 해당영역에 있다면
                         With rngA.Characters(Findex, Len(mat1(0)))  '= 해당 위치의 단어들을
                             .Font.Color = vbRed        '= 색상변경
                             .Font.Bold = True          '= 굵기 강조
                         End With
                         
                         Findex = Findex + Len(mat1(0)) '= 해당 영역에 중복값을 찾기 위해 Findex값 변경
                       End If
                 On Error GoTo 0
                 Next j
                 End If
                         
             Next i
         Next rngA
        
    End If
        Set rngX = rngX.Offset(1)                       '= 다음 행으로 변경
    Loop
    
End Sub
Function Haja_Reg()
    Set Haja_Reg = CreateObject("vbscript.regexp")
End Function

                   

 

단어색상입히기(22.05.04).xlsm

0.03MB