find and delete duplicates

rcVBA · #1 05-14-2013, 06:39 AM

I have a Word file with image names on each line. For example,

abc_bw.jpg
def_zq.jpg
img45cdgf.jpg
abc_logo.jpg
def_zq.jpg
img45cdgf.jpg
abc_bw.jpg

I have VBA code that selects the first line, compares the selected line with the following line, if the lines match the duplicate line is deleted, then the cursor moves down to the next line and compares that line to the selected line. When it reaches end, the "selected" line moves down one line and the process repeats until each line is compared with all the following lines and all duplicate lines have been deleted. This works ok for 5 or 6 lines, but with each additional line the time it take to process increases exponentially. Does anyone have any better ideas for how to find and delete the duplicate lines? Maybe with some sort of array? Thanks for any help you can provide.

macropod · #2 05-14-2013, 08:22 PM

Try:

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrFnd As String
With ActiveDocument
  For i = .Paragraphs.Count To 1 Step -1
    StrFnd = .Paragraphs(i).Range.Text
    With .Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = StrFnd
      .Replacement.Text = ""
      .Format = False
      .Forward = True
      .Wrap = wdFindContinue
      .MatchAllWordForms = False
      .MatchCase = False
      .MatchWholeWord = True
      .MatchWildcards = False
      .Execute Replace:=wdReplaceAll
    End With
    .Range.InsertAfter StrFnd
  Next
End With
Application.ScreenUpdating = True
End Sub

rcVBA · #3 05-15-2013, 06:04 AM

Excellent! Thank You very much. The code is perfect and it runs very fast.
I added two things (below) I found that if there was an empty paragraph at the end of the list, the code wouldn't run, so I added some code to delete an empty paragraph mark, if there is one, and second, I added a line to move the cursor to the beginning of the file before running the rest of the code.
Thanks again!

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrFnd As String
With ActiveDocument

' the code below deletes the last paragraph mark at the end of the doc
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p^p"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    With Selection
        If .Find.Forward = True Then
            .Collapse Direction:=wdCollapseStart
        Else
            .Collapse Direction:=wdCollapseEnd
        End If
        .Find.Execute Replace:=wdReplaceOne
        If .Find.Forward = True Then
            .Collapse Direction:=wdCollapseEnd
        Else
            .Collapse Direction:=wdCollapseStart
        End If
        .Find.Execute
    End With
' the code above deletes the last paragraph mark at the end of the doc

' move to the beginning of the document
Selection.HomeKey Unit:=wdStory

  For i = .Paragraphs.Count To 1 Step -1
    StrFnd = .Paragraphs(i).Range.Text
    With .Range.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = StrFnd
      .Replacement.Text = ""
      .Format = False
      .Forward = True
      .Wrap = wdFindContinue
      .MatchAllWordForms = False
      .MatchCase = False
      .MatchWholeWord = True
      .MatchWildcards = False
      .Execute Replace:=wdReplaceAll
    End With
    .Range.InsertAfter StrFnd
  Next
End With
Application.ScreenUpdating = True
End Sub

macropod · #4 05-15-2013, 02:41 PM

The following should be even faster, and won't trip up on any empty paragraphs left behind by your '^p^p' Find/Replace (eg if there were two consecutive empty paragraphs)

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim i As Long, StrFnd As String, Rng As Range
With ActiveDocument
  With .Range.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "[^13]{2,}"
    .Replacement.Text = "^p"
    .Format = False
    .Forward = True
    .Wrap = wdFindContinue
    .MatchAllWordForms = False
    .MatchCase = False
    .MatchWholeWord = True
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  While .Characters.Last.Previous.Text = vbCr
    .Characters.Last.Previous.Text = vbNullString
  Wend
  Set Rng = .Range
  For i = .Paragraphs.Count To 2 Step -1
    With .Paragraphs(i).Range
      StrFnd = .Text
      Rng.End = .Start
    End With
    With Rng.Find
      .Text = StrFnd
      .Replacement.Text = ""
      .MatchWildcards = False
      .Wrap = wdFindStop
      .Execute Replace:=wdReplaceAll
    End With
  Next
End With
Application.ScreenUpdating = True
End Sub

rcVBA · #5 05-15-2013, 03:08 PM

Very, very, nice. I didn't like using ^p^p, it was kind of clumsy. Thanks for teaching me about

Code:

[^13]{2,}

it works great.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
How to find out the duplicates and highlight them?	Learner7	Excel	6	06-08-2017 06:04 AM
Word Macro to find and delete rows that contain adjacent cells containing "."	AlexanderJohnWilley	Word VBA	7	11-08-2012 10:15 AM
Find/Delete inline Page #'s	alderfall	Word	6	11-06-2012 11:51 AM
Find duplicates formula	hannu	Excel	2	10-26-2010 02:48 AM
sum of duplicates	zxmax	Excel	1	09-29-2006 08:29 PM