Delete duplicate text in a table cell 2

[PStrongs]

Hi,

I have a table cell that contains text from another document. The text can contain many paragraphs and some paragraphs have duplicate paragraphs within the same cell.

I have tried to loop through the text to find and delete all duplicates, but without much success. To illustrate, the following text is an example of the table cell text:

Oranges
Apples
Pears
Grapes
Oranges
Grapes
Peaches
Oranges
Mango

I tried the following code but get a typemismatch error.
Still learning VBA, so would appreciate some help

Private Sub delPara()

Dim myTable As Table
Dim tPara As Paragraph
Dim tRange As Range, tRangeDel As Paragraph
Dim tParaCount As Long
Dim tParaTxt As String

Set myTable = Selection.Tables(1)
Set tRange = myTable.Cell(10, 2).Range
For tParaCount = 1 To tRange.Paragraphs.Count
Set tRangeDel = tRange.Paragraphs(tParaCount)

For Each tPara In Paragraphs
With tRange.Find
.Forward = True
.ClearFormatting
.MatchWholeWord = True
.MatchCase = False
.Wrap = wdFindContinue
.Execute FindText:=tRangeDel
If tRangeDel Then
Selection.Delete
End If
End With

Next tPara
Next tParaCount

End Sub

Regards,

 

[macropod]

Hi PStrongs,

Here's some code I've used for a similar task. I'm sure there are more efficient ways to do this, but it did the job for me.

Option Explicit
Dim SBar As Boolean           ' Status Bar flag
Dim TrkStatus As Boolean      ' Track Changes flag

Private Sub MacroEntry()
' Store current Status Bar status, then switch on
SBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
' Store current Track Changes status, then switch off
With ActiveDocument
    TrkStatus = .TrackRevisions
    .TrackRevisions = False
End With
' Turn Off Screen Updating
Application.ScreenUpdating = False
End Sub

Private Sub MacroExit()
'Clear the Status Bar
Application.StatusBar = False
' Restore original Status Bar status
Application.DisplayStatusBar = SBar
' Restore original Track Changes status
ActiveDocument.TrackRevisions = TrkStatus
' Restore Screen Updating
Application.ScreenUpdating = True
End Sub

Sub KillDuplicateParas()
Call MacroEntry
Dim i As Long, j As Long
Dim eTime As Single
eTime = Timer
With ActiveDocument
    If .Paragraphs.Count > 1 Then
        ' Loop backwards to preserve paragraph count & indexing.
        ' Start at 2nd-last paragraph.
        For i = .Paragraphs.Count - 1 To 1 Step -1
            ' Ignore empty paragraphs
            If Len(.Paragraphs(i).Range.Text) > 1 Then
                ' Loop backwards to preserve paragraph count & indexing.
                ' Stop at paragraph after current paragraph.
                For j = .Paragraphs.Count To i + 1 Step -1
                    ' Report progress on Status Bar.
                    Application.StatusBar = i & " paragraphs to check. "
                    ' No point in checking within paragraphs of unequal length.
                    If Len(.Paragraphs(i).Range) = Len(.Paragraphs(j).Range) Then
                        ' Test strings of paragraphs of equal length.
                        If .Paragraphs(i).Range = .Paragraphs(j).Range Then
                            ' Delete duplicate paragraph.
                            .Paragraphs(j).Range.Delete
                            ' or colour text of duplicate paragraph.
                            '.Paragraphs(j).Range.Font.Color = wdColorRed
                        End If
                    End If
                Next
            End If
        Next
    End If
End With
MsgBox "Finished. Elapsed time: " & (Timer - eTime + 86400) Mod 86400 & " seconds."
Call MacroExit
End Sub

As written, the code acts on the whole document. If you want it to act only on a selection, simply change 'ActiveDocument' to 'Selection' - or 'Selection.Tables(1).Range' to limit it to the first table in the selected range.

Cheers

[MS MVP - Word]

 

[PStrongs]

Hi macropod,

Stripped your code down to suit my requirements and it works like a dream!

Many thanks for your response.

Regards,

 

[fumei]

macropod, try your code with:

Mango
Oranges
Apples
Mango
Pears
Grapes
Oranges
Grapes
Mango
Peaches
Mango
Oranges
Mango

Also, if there is a paragraph mark followed by a end-of-cell marker (quite common) it will fail.

Here is a possible alternative.

Sub DelDups()
Dim aCell As Cell
Dim r As Range
Dim oPara As Paragraph
Dim j As Long
Dim var
On Error Resume Next

Set aCell = Selection.Cells(1)
j = aCell.Range.Paragraphs.Count
For var = 1 To j
   Set r = aCell.Range.Paragraphs(var).Range
      For Each oPara In aCell.Range.Paragraphs
         If oPara.Range.Start <> r.Start Then
            If oPara.Range.Text = r.Text Then
               oPara.Range.Delete
            End If
         End If
      Next
   If var >= aCell.Range.Paragraphs.Count Then Exit For
Next
Set aCell = Nothing
End Sub

It will remove all duplicate paragraphs from the cell the Selection is in.

Note it will remove duplicate "extra" paragraphs as well. Those "extra" (empty) paragraphs people use.

This is a sentence.
This is a sentence.
This is not a sentence. This is a sentence.
This is a sentence.
^p
This is a not sentence. This is a sentence.
^p
^p
This is a not sentence. This is a sentence.
^p
^p
^p
end-of-cell marker


will become:

This is a sentence.
This is a not sentence. This is a sentence.
^p
end-of-cell marker

For me, as I use Styles, and never those "extra" paragraphs, this work fine. If those in-between "extra" paragraphs are required, it would need a test for that. Something like:

Sub DelDups()
Dim aCell As Cell
Dim r As Range
Dim oPara As Paragraph
Dim j As Long
Dim var
On Error Resume Next

Set aCell = Selection.Cells(1)
j = aCell.Range.Paragraphs.Count
For var = 1 To j
   [b]If aCell.Range.Paragraphs(var).Range.Text <> Chr(13)[/b] Then
      Set r = aCell.Range.Paragraphs(var).Range
         For Each oPara In aCell.Range.Paragraphs
            If oPara.Range.Start <> r.Start Then
               If oPara.Range.Text = r.Text Then
                  oPara.Range.Delete
               End If
            End If
         Next
   End If
   If var >= aCell.Range.Paragraphs.Count Then Exit For
Next
Set aCell = Nothing
End Sub

Note: there is no error checking to see if the Selection is actually IN a cell - a good idea; and it only works for one cell. If the Selection covered two cells, only the first one would be actioned.

It would be very easy to adjust for both of those issues, if required.

faq219-2884

Gerry
My paintings and sculpture

 

[fumei]

Of course, if you wanted to do the whole active document:

Sub RemoveALLDups()
Dim DocRange As Range
Dim r As Range
Dim oPara As Paragraph
Dim j As Long
Dim var
On Error Resume Next
Set DocRange = ActiveDocument.Range
j = DocRange.Paragraphs.Count
   For var = 1 To j
      Set r = DocRange.Paragraphs(var).Range
      For Each oPara In DocRange.Paragraphs
         If oPara.Range.Start <> r.Start Then
            If oPara.Range.Text = r.Text Then
               oPara.Range.Delete
            End If
         End If
      Next
      If var >= DocRange.Paragraphs.Count Then
         Exit For
      End If
   Next
Set DocRange = Nothing
End Sub

will remove all duplicate paragraphs, including any in tables.

faq219-2884

Gerry
My paintings and sculpture

 

[PStrongs]

Hi Fumei,

Tried your suggestion too and works great.

Many thanks,

Regards,