Count Highlighted Text Macro

[Ethen5155]

Hi all,

i hope you can help me badly about this case as i spent a lot of time to get in in VBA but unfortunately i failed

as you see i have a table with 4 columns

i want to count highlighted text between brackets in first column (English) and put its count number in second column (Count E), the same for other two columns as shown in screenshot below


1.jpg

Sample.docxSample.docx

i attached sample file too


is it possible???


Thanks in advance


cheers

Ethen

[macropod]

Try a macro such as:

Sub Demo()
Application.ScreenUpdating = False
Dim r As Long, c As Long, w As Long, i As Long
With ActiveDocument.Tables(1)
  For r = 1 To .Rows.Count
    For c = 1 To 3 Step 2
      With .Cell(r, c).Range
        i = 0
        For w = 1 To .Words.Count
          If .Words(w).HighlightColorIndex <> wdNoHighlight Then i = i + 1
        Next
      End With
      .Cell(r, c + 1).Range.Text = i
    Next
  Next
End With
Application.ScreenUpdating = True
End Sub

For PC macro installation & usage instructions, see: http://www.gmayor.com/installing_macro.htm
For Mac macro installation & usage instructions, see: http://word.mvps.org/Mac/InstallMacro.html

[Ethen5155]

Dear Paul,

i found this result and i think it doesn't count it right as it supposed to put just number(2) for English and (3) for German on first row

2.jpg


Thanks

[Ethen5155]

i just need to count highlighted text between brackets like [1]-[2]-{2]-[5}...etc

cheers

Ethen

[macropod]

It seems:
If .Words(w).HighlightColorIndex <> wdNoHighlight Then i = i + 1
generates a spurious additional count. Additionally, your non-alphanumeric characters also get treated as words in their own right Try:

Sub Demo()
Application.ScreenUpdating = False
Dim r As Long, c As Long, w As Long, i As Long
With ActiveDocument.Tables(1)
  For r = 1 To .Rows.Count
    For c = 1 To 3 Step 2
      With .Cell(r, c).Range
        i = 0
        For w = 1 To .Words.Count
          With .Words(w)
            If .HighlightColorIndex = wdYellow Then
              If .Characters.First Like "[0-9A-Za-z]" Then i = i + 1
            End If
          End With
        Next
      End With
      .Cell(r, c + 1).Range.Text = i
    Next
  Next
End With
Application.ScreenUpdating = True
End Sub

[Ethen5155]

Wow, that is so fabulous


Thanks a lot for your generous efforts Paul

Cheers

Ethen

[Ethen5155]

Dear Paul

sorry for bothering you, i'm just asking for one more last editing

is it possible to add one more line to compare between both count numbers and if not matching then change the cell background to any color like orange for ex.

as shown

3.jpg

[macropod]

Try:

Sub Demo()
    Application.ScreenUpdating = False
    Dim r As Long, c As Long, w As Long, i As Long, j As Long
    With ActiveDocument.Tables(1)
        For r = 1 To .Rows.Count
            For c = 1 To 3 Step 2
                With .Cell(r, c).Range
                    i = 0
                    For w = 1 To .Words.Count
                        With .Words(w)
                            If .HighlightColorIndex = wdYellow Then
                                If .Characters.First Like "[0-9A-Za-z]" Then i = i + 1
                            End If
                        End With
                    Next
                End With
                With .Cell(r, c + 1)
                    .Range.Text = i
                    If c = 1 Then
                        j = i
                    ElseIf i = j Then
                        .Shading.BackgroundPatternColorIndex = wdNoHighlight
                        .Range.Words(1).HighlightColorIndex = wdNoHighlight
                    ElseIf i <> j Then
                        .Shading.BackgroundPatternColorIndex = wdYellow
                        .Range.Words(1).HighlightColorIndex = wdWhite
                    End If
                End With
            Next
        Next
    End With
    Application.ScreenUpdating = True
End Sub

[gmaxey]

Paul,

Welcome back, but I wish you would not exercise your role of "moderator" wit such zeal. While I was busy writing a solution for this poster (a post you recently deleted) you were busy deleting it.

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey
Dim oRow As Row
Dim oTbl As Table
For Each oTbl In ActiveDocument.Tables
  For Each oRow In oTbl.Rows
    If IsNumeric(Left(oRow.Cells(2).Range.Text, Len(oRow.Cells(2).Range.Text) - 2)) Then
    If oRow.Cells(2).Range.Text <> oRow.Cells(4).Range.Text Then
      oRow.Range.Cells(4).Shading.BackgroundPatternColor = wdColorOrange
    Else
      oRow.Range.Cells(4).Shading.BackgroundPatternColor = wdColorAutomatic
    End If
    End If
  Next
Next
lbl_Exit:
  Exit Sub
End Sub

[macropod]

Hi Greg. As you can see, the other post was essentially a duplicate of post #7 here. It's still there - just not visible to you. Even we moderators sometimes find threads/posts we're moderating being gazumped by the moderations of others...

[Ethen5155]

well both codes are awesome really, Paul & Gregyour help are highly appreciated..

i wish you all the luck and success while moderating this forum

Cheers

Ethen