Removing Identical Rows

ranjan · #1 02-09-2022, 12:38 PM

This was my regular task, which was taking more time to manually process this, I don’t know whether it can be possible or not to automate this task by VBA, I get a hope because you work like a pro and make all the things possible....

If anything, wrong or not seems realistic, please excuse me....

Am a basic learner and I tried from my side by recording a macro and worked on that macro, but it doesn’t seems meaningful for me and I tried to copy from other sites but not worked for me....

Task:

In a document am having word table, having three columns and n no of rows.

I want to delete a duplicate line or words in a row, range is start from 4th row and 2nd column to end of the table.

Then I want to calculate a word count, range is from 4th row, 3rd column to last row of the table and after running a macro it will displays a popup message as “Total word count: 73”

Format: .docx & .rtf

Remove duplicate rows is not a case sensitive.

Output document should be open and displays a word count message and output file will be saved in a same path with a same filename adding “_WC” to the existing file name.

Output document format either .docx or .rtf

Actual opened document should be closed, and output document should be opened after a running a macro.

Please find a attachment for better understanding.

I tried a below code from other sources but not worked, it might be helpful to others, so I pasted here.

Code:

Public Sub DeleteDuplicateRows()

    Dim xTable As Table
    Dim xRow As Range
    Dim xStr As String
    Dim xDic As Object
    Dim I, J, KK, xNum As Long
    If ActiveDocument.Tables.Count = 0 Then
        MsgBox "This document does not have table(s)."
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set xDic = CreateObject("Scripting.Dictionary")
    If Selection.Information(wdWithInTable) Then
        Set xTable = Selection.Tables(1)
        For I = xTable.Rows.Count To 1 Step -1
            Set xRow = xTable.Rows(I).Range
            xStr = UCase(xRow.Text)
            xNum = -1
            If xDic.Exists(xStr) Then
'                xTable.Rows(I).Delete
                For J = xTable.Rows.Count To 1 Step -1
                    If (xStr = xTable.Rows(J).Range.Text) And (J <> I) Then
                        xNum = xNum + 1
                        xTable.Rows(J).Delete
                    End If
                Next
                I = I - xNum
            Else
                xDic.Add xStr, I
            End If
        Next
    Else
        For I = 1 To ActiveDocument.Tables.Count
            Set xTable = ActiveDocument.Tables(I)
            xNum = -1
            xDic.RemoveAll
            For J = xTable.Rows.Count To 1 Step -1
                Set xRow = xTable.Rows(J).Range
                xStr = UCase(xRow.Text)
                xNum = -1
                If xDic.Exists(xStr) Then
    '                xTable.Rows(I).Delete
                    For KK = xTable.Rows.Count To 1 Step -1
                        If (xStr = xTable.Rows(KK).Range.Text) And (KK <> J) Then
                            xNum = xNum + 1
                            xTable.Rows(KK).Delete
                        End If
                    Next
                    J = J - xNum
                Else
                    xDic.Add xStr, J
                End If
            Next
        Next
    End If
    Application.ScreenUpdating = True
End Sub

Thanks in Advance....

Guessed · #2 02-10-2022, 12:39 AM

Try this version for the duplicate row deletion

Code:

Public Sub DeleteDuplicateRows2()
  Dim xTable As Table, xRow As Range, xStr As String, xDic As Object
  Dim I As Long, J As Long, KK As Long, xNum As Long, iRow As Long, iRows As Long
  Dim aRng As Range, cRng As Range

  'Application.ScreenUpdating = False
  Set xDic = CreateObject("Scripting.Dictionary")
  If Selection.Tables.Count = 0 Then
    MsgBox "Macro must be run when a table is selected"
    Exit Sub
  Else
    Set xTable = Selection.Tables(1)
    iRows = xTable.Rows.Count
    For I = iRows To 3 Step -1
      Set aRng = xTable.Rows(I).Range
      aRng.Start = aRng.Cells(2).Range.Start
      For iRow = 3 To I - 1
        Set cRng = xTable.Rows(iRow).Range
        cRng.Start = cRng.Cells(2).Range.Start
        If aRng.Text = cRng.Text Then
          xTable.Rows(I).Delete
          Exit For
        End If
      Next iRow
    Next I
  End If
  Application.ScreenUpdating = True
End Sub

ranjan · #3 02-10-2022, 02:51 AM

Thanks for the prompt response...

Its not working well, only one duplicate row was deleting if there are more than one it was not get deleting, please review the code once...

Is it possible to ammend the word count for this table or is it required to have a seperate macro for the WC Stats to the correct column (i.e. range from 4th row 3rd column to end of the table) and displays a message as WC = 73 (Only Word count stats is enough document was not required)

Guessed · #4 02-10-2022, 08:25 PM

Do you only want to count words in the second and third column? And is the count only after the duplicate rows have been removed?

ranjan · #5 02-10-2022, 08:51 PM

First I want to removed the duplicate rows (range from 4th row n 2 column to end of the table)

Then I want to know only word count of correct column (range from 4th row, 3rd column to end of table)

Just display msg of word count is enough or any other option is available to know wc if we can't integrate the wc into this macro. separate macro also we can try to know the wc rather than doing manually.

Thanks a lot for your prompt responses and great work....

Guessed · #6 02-10-2022, 10:08 PM

Does this work? I've changed it to only look at column 2 for deleting duplicates and only look at column 3 for your word count. Is that right?

Code:

Public Sub DeleteDuplicatesCol2()
  Dim xTable As Table, xRow As Range, xStr As String, xDic As Object
  Dim I As Long, J As Long, KK As Long, xNum As Long, iRow As Long, iRows As Long
  Dim aRng As Range, cRng As Range, lWords As Long, lRows As Long, aCell As Cell

  'Application.ScreenUpdating = False
  Set xDic = CreateObject("Scripting.Dictionary")
  If Selection.Tables.Count = 0 Then
    MsgBox "Macro must be run when a table is selected"
    Exit Sub
  Else
    Set xTable = Selection.Tables(1)
    iRows = xTable.Rows.Count
    For I = iRows To 4 Step -1
      Set aRng = xTable.Cell(I, 2).Range
      For iRow = 4 To I - 1
        Set cRng = xTable.Cell(iRow, 2).Range
        If aRng.Text = cRng.Text Then
          xTable.Rows(I).Delete
          lRows = lRows + 1
          Exit For
        End If
      Next iRow
    Next I
  End If
  Set aRng = ActiveDocument.Range(xTable.Rows(4).Range.Start, xTable.Range.End)
  For Each aCell In aRng.Cells
    If aCell.ColumnIndex = 3 Then lWords = lWords + aCell.Range.Words.Count - 1
  Next aCell
  
  Application.ScreenUpdating = True
  MsgBox "Word count in column 3: " & lWords
End Sub

ranjan · #7 02-10-2022, 11:38 PM

Quote:

Does this work? I've changed it to only look at column 2 for deleting duplicates and only look at column 3 for your word count. Is that right?

This Condition was exactly right and above codes work exactly but there was a mismatch of WC through VBA & Manual doing.

WC should be calculated after deleting a duplicate rows and range for WC is from 4th row & 3rd Column, Please find the above ZIP attachment for sample doc.
Through VBA WC is 86 & Manully WC is 73.

Its work very closely...

Plesee find the below link....

https://www.linkpicture.com/q/Macro_...-Duplicate.jpg

https://www.linkpicture.com/q/Manully_1.jpg

ranjan · #8 02-14-2022, 10:56 PM

Hi,

Complie Error: For without next....

Please review the below error, after a removing identical rows then calculate the wc for column 3.

Range is from 4th row & 3rd column and display a msg as "WC"

Code:

Public Sub DeleteDuplicatesCol3()

  Dim xTable As Table, xRow As Range, xStr As String, xDic As Object
  Dim I As Long, J As Long, KK As Long, xNum As Long, iRow As Long, iRows As Long
  Dim aRng As Range, cRng As Range, lWords As Long, lRows As Long, aCell As Cell
  Dim nWordsCount As Long
  Dim nCharCount As Long

  'Application.ScreenUpdating = False
  Set xDic = CreateObject("Scripting.Dictionary")
  If Selection.Tables.Count = 0 Then
    MsgBox "Macro must be run when a table is selected"
    Exit Sub
  Else
    Set xTable = Selection.Tables(1)
    iRows = xTable.Rows.Count
    For I = iRows To 4 Step -1
      Set aRng = xTable.Cell(I, 2).Range
      For iRow = 4 To I - 1
        Set cRng = xTable.Cell(iRow, 2).Range
        If aRng.Text = cRng.Text Then
          xTable.Rows(I).Delete
          lRows = lRows + 1
          Exit For
        End If
      Next iRow
    Next I
  End If
  
  Set aRng = ActiveDocument.Range(xTable.Rows(4).Range.Start, xTable.Range.End)
  
For Each aCell In aRng.Cells

 If aCell.ColumnIndex = 3 Then

nWordsCount = aRng.ComputeStatistics(wdStatisticWords)
nCharCount = aRng.ComputeStatistics(wdStatisticCharacters)
 
    Application.ScreenUpdating = True

    MsgBox "Word count in column 3: " & "The entire doc contains: " & vbCrLf & nWordsCount & " words and" & vbCrLf & _
           nCharCount & " characters without spaces", , "Word Count"

  End If

  
  End Sub

Guessed · #9 02-14-2022, 11:32 PM

Your second yellow line opens a For loop but you didn't include a Next aCell at the end.

Do a manual count of the words being returned by your code. If your code is returning an additional number of words that match the number of cells then it is likely you are also counting the end of cell markers as a word.

Thread Tools
Show Printable Version Email this Page
Display Modes
Linear Mode Switch to Hybrid Mode Switch to Threaded Mode

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Removing rows when mail merging	Richystab	Mail Merge	3	12-07-2020 03:05 AM
Identical computers	MeCasa	Office	0	09-23-2019 03:43 PM
Removing duplicate rows when identical value in a column	ballpoint	Excel	1	01-05-2018 08:54 AM
how to delete every blank and non-numeric rows without removing the header	enuff	Excel	3	08-24-2017 05:56 AM
How to find an identical sentences?	Bill K	Word	1	12-03-2015 12:16 AM