Finding/deleting repeated text within Cells of a table

[Marc131]

I am trying to find and delete repeated lines of text within a given cell of
a word table; and then repeat this same process for all cells of the table.
For example, in a given cell of a table, the line of text "XYZ_123" might be
repeated 3 three times. I need to delete the 2nd and 3rd occurrence of the
lines of text.

 

[Greg Maxey]

Marc,

Something like:
Sub Scratchmacro()
Dim oCell As Cell
Dim oRng As Word.Range
Dim i As Long
For Each oCell In Selection.Tables(1).Range.Cells
Set oRng = oCell.Range
oRng.End = oRng.End - 1
With oRng.Find
.Text = "XYZ_123"
While .Execute
i = i + 1
If i > 1 And oRng.Start < oCell.Range.End Then
oRng.Delete
End If
Wend
i = 0
End With
Next oCell
End Sub

 

[Greg Maxey]

Marc,

Provided XYZ_123 is a complete line in a cell, then this may do a
cleaner, faster job:

Sub Scratchmacro()
Dim oCell As Cell
Dim oRng As Word.Range
Dim i As Long
For Each oCell In Selection.Tables(1).Range.Cells
Set oRng = oCell.Range
With oRng.Find
.Text = "XYZ_123"
Do While .Execute
i = i + 1
If oRng.Start > oCell.Range.End Then Exit Do
oRng.MoveEnd wdCharacter, 1
If i > 1 And oRng.Start < oCell.Range.End Then
If oRng.End = oCell.Range.End Then
oRng.MoveStart wdCharacter, -1
oRng.MoveEnd wdCharacter, -1
End If
oRng.Delete
End If
oRng.Collapse wdCollapseEnd
Loop
i = 0
End With
Next oCell
End Sub

 

[Marc131]

I need something a bit more generic because every cell in the table has
different text. I need to delete any repeated (complete) line of text in a
given cell.

 

[Greg Maxey]

Try:

Sub ScratchMacro()
Dim pCell As Word.Cell
Dim oParagraphs As Paragraphs
Dim i As Long
Dim j As Long
Dim oRng As Range
Dim oRng2 As Word.Range

If Selection.Information(wdWithInTable) = True Then
Set pCell = Selection.Tables(1).Cell(1, 1)
Do
Set oRng = pCell.Range
oRng.MoveEnd wdCharacter, -1
Set oParagraphs = pCell.Range.Paragraphs
If oParagraphs.Count > 1 Then
oRng.Select
Selection.Range.Sort SortOrder:=wdSortOrderAscending
End If
For i = 1 To oParagraphs.Count
For j = i + 1 To oParagraphs.Count
If oParagraphs(i).Range.Text = oParagraphs(j).Range.Text Then
oParagraphs(j).Range.Delete
j = j - 1
Else
Exit For
End If
Next
Next
Set oRng = oParagraphs.Last.Range
Set oRng2 = oParagraphs.Last.Previous.Range
oRng.MoveEnd wdCharacter, -1
oRng2.MoveEnd wdCharacter, -1
If oRng.Text = oRng2.Text Then
oParagraphs.Last.Previous.Range.Delete
End If
Set pCell = pCell.Next
Loop Until pCell Is Nothing
Set pCell = Nothing
Set oRng = Nothing
Set oRng1 = Nothing
Set oParagraphs = Nothing
Else
MsgBox "A table has not been selected"
End If
End Sub

 

[Greg Maxey]

I thought about this some more and realized that the user might not
want the cell content sorted. The following seems to work (with very
limited testing).

Sub ScratchMacroII()
Dim pCell As Word.Cell
Dim oParagraphs As Paragraphs
Dim i As Long
Dim j As Long
Dim oRng As Range
Dim oRng2 As Word.Range
If Selection.Information(wdWithInTable) = True Then
Set pCell = Selection.Tables(1).Cell(1, 1)
Do
Set oParagraphs = pCell.Range.Paragraphs
For i = oParagraphs.Count To 2 Step -1
For j = oParagraphs.Count - 1 To 1 Step -1
Set oRng = oParagraphs(i).Range
Set oRng2 = oParagraphs(j).Range
oRng.MoveEnd wdCharacter, -1
oRng2.MoveEnd wdCharacter, -1
If oRng.Text = oRng2.Text Then
oParagraphs(j).Range.Delete
i = i - 1
j = j - 1
End If
Next j
Next i
Set pCell = pCell.Next
Loop Until pCell Is Nothing
Set pCell = Nothing
Set oRng = Nothing
Set oRng2 = Nothing
Set oParagraphs = Nothing
Else
MsgBox "A table has not been selected"
End If
End Sub

 

[Greg Maxey]

Marc,

Trash the last two suggestions :-(. I still don't guarantee this is
100% reliable, but it corrects mistakes I found in the last posts:

Sub ScratchMacroII()
Dim pCell As Word.Cell
Dim oParagraphs As Paragraphs
Dim i As Long
Dim j As Long
Dim oRng As Range
Dim oRng2 As Word.Range
If Selection.Information(wdWithInTable) = True Then
Set pCell = Selection.Tables(1).Cell(1, 1)
Do
Set oParagraphs = pCell.Range.Paragraphs
For i = oParagraphs.Count To 2 Step -1
For j = i - 1 To 1 Step -1
Set oRng = oParagraphs(i).Range
Set oRng2 = oParagraphs(j).Range
oRng.MoveEnd wdCharacter, -1
oRng2.MoveEnd wdCharacter, -1
If oRng.Text = oRng2.Text Then
oParagraphs(j).Range.Delete
i = i - 1
End If
Next j
Next i
Set pCell = pCell.Next
Loop Until pCell Is Nothing
Set pCell = Nothing
Set oRng = Nothing
Set oRng2 = Nothing
Set oParagraphs = Nothing
Else
MsgBox "A table has not been selected"
End If
End Sub

 

[Marc131]

Greg,
Thanks. This appears to do the trick!
Marc

Marc,

Trash the last two suggestions :-(. I still don't guarantee this is
100% reliable, but it corrects mistakes I found in the last posts:

Sub ScratchMacroII()
Dim pCell As Word.Cell
Dim oParagraphs As Paragraphs
Dim i As Long
Dim j As Long
Dim oRng As Range
Dim oRng2 As Word.Range
If Selection.Information(wdWithInTable) = True Then
Set pCell = Selection.Tables(1).Cell(1, 1)
Do
Set oParagraphs = pCell.Range.Paragraphs
For i = oParagraphs.Count To 2 Step -1
For j = i - 1 To 1 Step -1
Set oRng = oParagraphs(i).Range
Set oRng2 = oParagraphs(j).Range
oRng.MoveEnd wdCharacter, -1
oRng2.MoveEnd wdCharacter, -1
If oRng.Text = oRng2.Text Then
oParagraphs(j).Range.Delete
i = i - 1
End If
Next j
Next i
Set pCell = pCell.Next
Loop Until pCell Is Nothing
Set pCell = Nothing
Set oRng = Nothing
Set oRng2 = Nothing
Set oParagraphs = Nothing
Else
MsgBox "A table has not been selected"
End If
End Sub