Color-code each letter according to his spreadsheet value

[zhz]

Hi,

I can't solve this problem. I need to create a macro that:
1) Select each character in a text
2) Find that character in a spreadsheet and get the number of his row.
3) Color code (i.e. change the color) the character in the original text according to that number (example, if the character was found between the rows 1-150 color it with blue, if it was in row 151-500 in green, etc.).

I hope the image helps.

Massive thanks,


Zhz

[macropod]

Whilst it's not hard to do the colouring, your worksheet entry on row 85 appears to have multiple characters, including one that appears on row 84. In that case, your arrangement looks likely to create conflicts, with different colours being applied to the same character depending on the order they're input into your workbook.

[zhz]

Originally Posted by macropod

Whilst it's not hard to do the colouring, your worksheet entry on row 85 appears to have multiple characters, including one that appears on row 84. In that case, your arrangement looks likely to create conflicts, with different colours being applied to the same character depending on the order they're input into your workbook.

While similars, those characters are different, the one in 85 has ⻈ in front of it: 84=人 85=认. Anyhow, that picture is just an example of what I was needing, I have multiple texts to analize.

Thanks!

[macropod]

The following code will allow you to process 1950 expressions before the colours repeat. For ease of use, I've eliminated black, white & light grey.

Sub ColorCharacterBlocks()
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim iDataRow As Long, xlFList, i As Long, j As Long
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\CharacterList.xlsx"
StrWkSht = "Sheet1"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit
    Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    'Ensure the worksheet exists
    If SheetExists(StrWkSht) = True Then
      With .Worksheets(StrWkSht)
        ' Find the last-used row in column A.
        iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
        ' Capture the F/R data.
        For i = 1 To iDataRow
          ' Skip over empty fields to preserve the underlying cell contents.
          If Trim(.Range("A" & i)) <> vbNullString Then
            xlFList = xlFList & "|" & Trim(.Range("A" & i))
          End If
        Next
      End With
    Else
      MsgBox "Cannot find the designated worksheet: " & StrWkSht, vbExclamation
    End If
  .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub
'Process each word from the F/R List
For i = 1 To UBound(Split(xlFList, "|"))
  j = (Int(i / 150)) Mod 13
  If j < 6 Then
    j = j + 2
  Else
    j = j + 3
  End If
  With ActiveDocument.Range
    With .Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Format = True
      .Wrap = wdFindContinue
      .Text = Split(xlFList, "|")(i)
      .Replacement.Text = "^&"
      .Replacement.Font.ColorIndex = j
      'ColorIndex values:
      ' 1=Black; 2=Blue; 3=Turquoise;
      ' 4=BrightGreen; 5=Pink; 6=Red;
      ' 7=Yellow; 8=White; 9=DarkBlue;
      ' 10=Teal; 11=Green; 12=Violet;
      ' 13=DarkRed; 14=DarkYellow; 15=Gray50
      .Execute Replace:=wdReplaceAll
    End With
  End With
Next
Application.ScreenUpdating = True
End Sub

Function SheetExists(SheetName As String) As Boolean
Dim i As Long: SheetExists = False
For i = 1 To Sheets.Count
  If Sheets(i).Name = SheetName Then
    SheetExists = True:   Exit For
  End If
Next
End Function

Edit the following two lines of code to match your workbooks name & path and sheet name:
StrWkBkNm = "C:\Users\" & Environ("Username") & "\Documents\BulkFindReplace.xlsx"
StrWkSht = "Sheet1"
The above two lines assume the workbook is stored in your 'Documents' folder and is named 'CharacterList.xlsx'. The worksheet is assumed to be named 'Sheet1'.

[zhz]

Macropod,

I don't know how to express my gratitude, you saved me hours of work. My best wishes to you