View Full Version : [SOLVED:] Check macro
baset
02-23-2016, 12:12 PM
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
02-23-2016, 10:26 PM
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
02-24-2016, 04:40 AM
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
02-28-2016, 01:53 AM
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
02-29-2016, 05:37 AM
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
02-29-2016, 06:43 AM
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
02-29-2016, 07:05 AM
You are the best i ever met Mr. Graham Mayor :hi:
baset
02-29-2016, 07:15 AM
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
02-29-2016, 10:36 AM
I forget to add something that the text inside column 2 should have different text than what found on column 1
gmayor
02-29-2016, 10:15 PM
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
03-01-2016, 02:29 AM
sorry sir for that confusion; Here you are a real file:
gmayor
03-01-2016, 05:29 AM
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
03-01-2016, 06:51 AM
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
03-01-2016, 07:40 AM
You are welcome :)
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.