Check macro

[baset]

Dear all

Can you plz help me here; this is a macro that check tags like [any number] by comparing tabled word file


Sub Baset_Check_MemoQ_Tags()



Dim oTable As Table, oRow As Range, oCell As Cell, _
NumRows As Long, NumCells As Long, TextInRow As Boolean, myRange As Range, _
Counter As Long, i1 As Long, i2 As Long, i3 As Integer




' Find #1


i3 = 0


Selection.HomeKey Unit:=wdStory, Extend:=wdExtend
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCell


Set oTable = Selection.Tables(1)
Set oRow = oTable.Rows(1).Range
NumRows = oTable.Rows.Count


For Counter = 2 To NumRows

Selection.MoveRight Unit:=wdCell
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Set myRange = Selection.Range
myRange.Find.ClearFormatting
myRange.Find.Highlight = True
With myRange.Find
.Wrap = wdFindStop
.Text = "[^#]"
Do While myRange.Find.Execute
i1 = i1 + 1
Loop
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
End With

Selection.MoveRight Unit:=wdCell
Options.DefaultHighlightColorIndex = wdYellow
Selection.Range.HighlightColorIndex = wdYellow
Set myRange = Selection.Range
myRange.Find.ClearFormatting
myRange.Find.Highlight = True
With myRange.Find
.Wrap = wdFindStop
.Text = "[^#]"
Do While myRange.Find.Execute
i2 = i2 + 1
Loop
Options.DefaultHighlightColorIndex = wdNoHighlight
Selection.Range.HighlightColorIndex = wdNoHighlight
End With

If i2 <> i1 Then
Selection.Shading.BackgroundPatternColor = 5287936
i3 = 1
End If
i1 = 0
i2 = 0


Next Counter








End Sub





When i run it works only if the cell have 1 tag only while it should check all tags inside the cell; see it marks 3 rows only and skip the 1st one:

15457

and here you are the test file attached.

[gmayor]

What EXACTLY is the macro supposed to do? I can see from your document that column 1 has numbers with assorted brackets and column 2 also has assorted numbers and brackets. What then are you attempting to do with those columns, brackets and numbers?

[baset]

Thanks sir for your reply; I'm trying to write a macro that compare these 2 columns and check if the (brackets+number) on the left cell is matching the right cell or not; if not the cell that have any missing will be highlighted.

[gmayor]

I have to say that this conundrum has been bugging me for a few days, with the second check in the first row causing the most grief. The remainder is straightforward, provided the example is representative. However I think the following should do the trick (it certainly does with the test document).

Option Explicit

Sub CompareTags()
Dim oTable As Table
Dim oRow As Row
Dim oCellA As Range
Dim oCellB As Range
Dim oRng As Range
Dim sText As String
Dim i As Integer, j As Integer
Set oTable = ActiveDocument.Tables(1)
For Each oRow In oTable.Rows
Set oCellA = oRow.Cells(1).Range
oCellA.End = oCellA.End - 1
Set oRng = oRow.Cells(1).Range
oRng.End = oRng.End - 1
Set oCellB = oRow.Cells(2).Range
oCellB.End = oCellB.End - 1
j = 0
With oRng.Find
Do While .Execute(FindText:="[\[\]\{\}0-9]{2,}", MatchWildcards:=True)
If oRng.InRange(oCellA) Then
j = j + 1
i = InStr(1, oCellA.Text, oRng.Text)
If j > 1 Then
oCellB.Start = oCellB.Start + i + Len(oRng) - 1
End If
If InStr(i - Len(oRng.Text), oCellB.Text, oRng.Text) = 0 Then
oRow.Cells(2).Range.Shading.BackgroundPatternColor = 12303359
End If
oRng.Collapse 0
End If
Loop
End With
Next oRow
lbl_Exit:
Set oTable = Nothing
Set oRow = Nothing
Set oRng = Nothing
Set oCellA = Nothing
Set oCellB = Nothing
Exit Sub
End Sub

[baset]

Dear Sir

You are wonderful doing this and change the code to be faster.

how can make your macro start from this marked cell and still compare only the columns 2 & 3

15500

[gmayor]

It needs a few minor changes to achieve that:

Option Explicit

Sub CompareTags()
Dim oTable As Table
Dim oRow As Row
Dim oCellA As Range
Dim oCellB As Range
Dim oRng As Range
Dim sText As String
Dim lngRow As Long
Dim i As Integer, j As Integer
Set oTable = ActiveDocument.Tables(1)
For lngRow = 3 To oTable.Rows.Count
Set oRow = oTable.Rows(lngRow)
Set oCellA = oRow.Cells(2).Range
oCellA.End = oCellA.End - 1
Set oRng = oRow.Cells(2).Range
oRng.End = oRng.End - 1
Set oCellB = oRow.Cells(3).Range
oCellB.End = oCellB.End - 1
j = 0
With oRng.Find
Do While .Execute(FindText:="[\[\]\{\}0-9]{2,}", MatchWildcards:=True)
If oRng.InRange(oCellA) Then
j = j + 1
i = InStr(1, oCellA.Text, oRng.Text)
If j > 1 Then
oCellB.Start = oCellB.Start + i + Len(oRng) - 1
End If
If InStr(i - Len(oRng.Text), oCellB.Text, oRng.Text) = 0 Then
oRow.Cells(3).Range.Shading.BackgroundPatternColor = 12303359
End If
oRng.Collapse 0
End If
Loop
End With
Next lngRow
lbl_Exit:
Set oTable = Nothing
Set oRow = Nothing
Set oRng = Nothing
Set oCellA = Nothing
Set oCellB = Nothing
Exit Sub
End Sub

[baset]

You are the best i ever met Mr. Graham Mayor :hi:

[baset]

sorry sir there is a bug; when i test the latest macro on a correct file that has no any tags missing it also mark some cells as shown below:

15503

the test file is attached.

[baset]

I forget to add something that the text inside column 2 should have different text than what found on column 1

[gmayor]

Instead of keep moving the goalposts, post a sample that is an accurate reflection of what you are trying to achieve. Will there always be a maximum of two tags in the columns?

[baset]

sorry sir for that confusion; Here you are a real file:

[gmayor]

Given the differences between the two documents, this needs a different approach. The following adds each occurrence of the three coloured tag characters to a separate string for each English and each Arabic cell in each row. If the tags match, the two strings should be the same. If any of the tags in a row don't match, the two strings will be different and the column is shaded pink. This seems to work correctly with yoiur example document.

Option Explicit

Sub CompareTags()
Dim oTable As Table
Dim oRow As Row
Dim oCellA As Range
Dim oCellB As Range
Dim oRng As Range
Dim sEnglish As String, sArabic As String
Dim lngRow As Long
Set oTable = ActiveDocument.Tables(1)
For lngRow = 3 To oTable.Rows.Count
Set oRow = oTable.Rows(lngRow)
Set oCellA = oRow.Cells(2).Range
oCellA.End = oCellA.End - 1
Set oRng = oRow.Cells(2).Range
oRng.End = oRng.End - 1
Set oCellB = oRow.Cells(3).Range
oCellB.End = oCellB.End - 1
sEnglish = "": sArabic = ""
With oRng.Find
.Font.Color = RGB(128, 0, 0)
Do While .Execute(FindText:="[\[\]\{\}0-9]{3}", MatchWildcards:=True)
If oRng.InRange(oCellA) Then
sEnglish = sEnglish & Trim(oRng.Text)
oRng.Collapse 0
End If
Loop
End With
Set oRng = oRow.Cells(3).Range
oRng.End = oRng.End - 1
With oRng.Find
.Font.Color = RGB(128, 0, 0)
Do While .Execute(FindText:="[\[\]\{\}0-9]{3}", MatchWildcards:=True)
If oRng.InRange(oCellB) Then
sArabic = sArabic & Trim(oRng.Text)
oRng.Collapse 0
End If
Loop
End With
If Not sEnglish = sArabic Then
oRow.Cells(3).Range.Shading.BackgroundPatternColor = 12303359
End If
Next lngRow
lbl_Exit:
Set oTable = Nothing
Set oRow = Nothing
Set oRng = Nothing
Set oCellA = Nothing
Set oCellB = Nothing
Exit Sub
End Sub

[baset]

Dear Graham Mayor

Really you are the best Macros' developer i ever met; Also you are the best supporter i ever met.

I can't express my feelings after running the Macro and it works very well.

Lot of THANKS sir.

[gmayor]

You are welcome :)