Microsoft Office Forums - View Single Post

ranjan · 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....