Solved: How to find the occurrence of dates and compare

[mousepant]

Hi All,

It would be very helpful if I can get help with this. I am in documentation and usually have to read through pages and pages of documents. Each document would have 1000s of paragraphs like the below ones.

On June 9, 2010, Mr. X underwent an IR 5-French, 43-cm, single-lumen PICC line placement from the right basilic vein, performed by Y, D.O. Mr. X had satisfactory insertion of the PICC line from the right.

Also on this date, x-rays of the chest revealed a single fluoroscopy view of the chest was obtained following insertion of a 5-French, 43-cm, single-lumen PICC line through the right basilic vein and the tip of the catheter was at the junction of the SVC and the right atrium.


On June 10, 2010, Mr. X underwent wound evaluation of left upper extremity, which was of length of 30+, width 18, and depth 3 with heavy drainage, positive ecchymosis and edema, and muscle and fatty tissue at base. Mr. Sandoval was recommended to apply Silvadene to left hand twice daily, 4 x 4’s, Kerlix, and Ace.


I have to do three things.
1. Get the date that follows "On" in each para and compare it with the next occurrence of date preceded by "On" in another para. Check whether these dates have been arranged historically. If not arranged in ascending order, highlight both dates with yellow color. Eg: Check June 9 paragraph comes before June 10, if not highlight both the dates.

2. Any dated paragraph should either be preceded by either a dated para or a para that starts with "Also on this date". Else it should highlight the first few words where this is not true. Eg. "On June 10, 2010," para is preceded by "Also on this date" or another June 9, 2010, else it should highlight first few words of the undated para.

3. a macro which should remove all the highlights in the document.

I know some coding and have been trying to do this for the past couple of weeks, but unable to do, hence seeking out for help. Your help would be greatly appreciated. Thanks for your help in advance.

[macropod]

Try:
Sub Demo()
Application.ScreenUpdating = False
Dim RngDoc As Range, RngFnd As Range, RngTmp As Range, StrDt As String
Dim i As Long, j As Long, oPara As Paragraph
j = 0
With ActiveDocument
Set RngDoc = .Range
Set RngFnd = .Range
Set RngTmp = .Range
With RngDoc
.HighlightColorIndex = wdNoHighlight
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "On [JFMASONDanuryebchpilgstmov]{3,9} [0-9]{1,2}, [12][0-9]{3}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
With .Duplicate
.Start = .Start + 3
i = CLng(CDate(.Text))
RngFnd.Start = .Paragraphs.Last.Range.End
RngTmp.Start = .Paragraphs.Last.Range.End
End With
With RngFnd
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "On [JFMASONDanuryebchpilgstmov]{3,9} [0-9]{1,2}, [12][0-9]{3}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
If .Find.Found Then
RngTmp.End = .Start
.Start = .Start + 3
j = CLng(CDate(.Text))
.Start = .Start - 3
If i > j Then .Duplicate.HighlightColorIndex = wdPink
End If
For Each oPara In RngTmp.Paragraphs
If InStr(oPara.Range.Text, "Also on this date") <> 1 Then
oPara.Range.Words.First.HighlightColorIndex = wdYellow
End If
Next
End With
'If i > j Then .Duplicate.HighlightColorIndex = wdPink
.Start = RngFnd.End
.Find.Execute
Loop
End With
End With
Application.ScreenUpdating = True
End Sub
Note: Where the dates are out of sequence, the code only highlights the first date in each sequence that is out of order. I'm not sure why you'd want to highlight the preceding date as well, but the code to do that is also there - commented out.

[macropod]

Cross-posted at: http://www.excelforum.com/word-formatting-and-general/926341-help-with-word-macro-regarding-dates.html
For cross-posting etiquette, please read: http://www.excelguru.ca/content.php?184

[mousepant]

Sorry for cross-posting, would avoid this in the future.

[mousepant]

Try:
Sub Demo()
Application.ScreenUpdating = False
Dim RngDoc As Range, RngFnd As Range, RngTmp As Range, StrDt As String
Dim i As Long, j As Long, oPara As Paragraph
j = 0
With ActiveDocument
Set RngDoc = .Range
Set RngFnd = .Range
Set RngTmp = .Range
With RngDoc
.HighlightColorIndex = wdNoHighlight
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "On [JFMASONDanuryebchpilgstmov]{3,9} [0-9]{1,2}, [12][0-9]{3}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
With .Duplicate
.Start = .Start + 3
i = CLng(CDate(.Text))
RngFnd.Start = .Paragraphs.Last.Range.End
RngTmp.Start = .Paragraphs.Last.Range.End
End With
With RngFnd
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "On [JFMASONDanuryebchpilgstmov]{3,9} [0-9]{1,2}, [12][0-9]{3}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
If .Find.Found Then
RngTmp.End = .Start
.Start = .Start + 3
j = CLng(CDate(.Text))
.Start = .Start - 3
If i > j Then .Duplicate.HighlightColorIndex = wdPink
End If
For Each oPara In RngTmp.Paragraphs
If InStr(oPara.Range.Text, "Also on this date") <> 1 Then
oPara.Range.Words.First.HighlightColorIndex = wdYellow
End If
Next
End With
'If i > j Then .Duplicate.HighlightColorIndex = wdPink
.Start = RngFnd.End
.Find.Execute
Loop
End With
End With
Application.ScreenUpdating = True
End Sub
Note: Where the dates are out of sequence, the code only highlights the first date in each sequence that is out of order. I'm not sure why you'd want to highlight the preceding date as well, but the code to do that is also there - commented out.

Hi,

Thank you very much! Some part is not working. I am not sure what.


On March 23, 2002, Mr. xxx

On May 30, 2012, Mr. xxxx.

Mr. xxx

On October 6, 2013, Mr. xxx

On May 10, 2011, Mr. xxx

On August 17, 2011, Mr. xxx

When I run the macro for this it is not working. It is highlighting On May 10, 2011 with pink and "On" of August 17 with yellow.

It should have highlighted Mr. XXX para, but it didn't.

It should have highlighted On May 30, 2012 and October 6, 2013 for wrong order.

One more thing, can you please explain the logic behind this code, so that I would also learn something.

Thanks!

[macropod]

Try this update - with comments to describe what it's doing
Sub Demo()
Application.ScreenUpdating = False
Dim RngFnd As Range, RngTmp As Range, StrDt As String
Dim i As Long, j As Long, oPara As Paragraph
j = 0
With ActiveDocument
' Set some working ranges
Set RngFnd = .Range
Set RngTmp = .Range
With .Range
'Kill all current highlighting
.HighlightColorIndex = wdNoHighlight
'Find a paragraph beginning with a month, day & year
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "On [JFMASONDanuryebchpilgstmov]{3,9} [0-9]{1,2}, [12][0-9]{3}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
With .Duplicate
'Isolate the date
.Start = .Start + 3
'Convert the date to a number
i = CLng(CDate(.Text))
're-set the subsidiary range ends
RngFnd.Start = .Paragraphs.Last.Range.End
RngTmp.Start = .Paragraphs.Last.Range.End
End With
'Find the next paragraph beginning with a month, day & year
With RngFnd
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "On [JFMASONDanuryebchpilgstmov]{3,9} [0-9]{1,2}, [12][0-9]{3}>"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
If .Find.Found Then
'Relocate the temporary range's start
RngTmp.End = .Start
'Isolate the date
.Start = .Start + 3
'Convert the date to a number
j = CLng(CDate(.Text))
'Restore the range start (for highlighting)
.Start = .Start - 3
'Compare the dates & highlight the second one if out of order
If i > j Then .Duplicate.HighlightColorIndex = wdPink
End If
With RngTmp
'Check the content of each para in the temporary range
For Each oPara In RngTmp.Paragraphs
With oPara.Range
'Highlight the first word in non-conforming paragraphs
If InStr(.Text, "Also on this date") <> 1 Then
If Not .Text Like "On [JFMASOND]* [0-9]*, [12][0-9][0-9][0-9]*" Then
.Words.First.HighlightColorIndex = wdYellow
End If
End If
End With
Next
End With
End With
'Compare the dates & highlight the first one if out of order
'If i > j Then .Duplicate.HighlightColorIndex = wdPink
'Do another round
.Start = RngFnd.Start
.Find.Execute
Loop
End With
End With
Application.ScreenUpdating = True
End Sub

[mousepant]

Thank you! It is now working and the comments are very useful. Thanks!