Table - Combine Rows upon certain criteria

Experts,

I have an extracted table and want to combine the rows if Page, Main Heading and Sub Heading are equal.  I want to combine them into one row.  You can see in the attached that for this criteria, there are  multiple rows and combining them would be easier to read.

How could this be done?  It is something that i will repeat often and vba code I suppose could do this.  
The headings will always be the same.  

Please see attached doc.  Thank you
Extract-DocTEST.doc
pdvsaProject financeAsked:
Who is Participating?
 
GrahamSkanRetiredCommented:
Only a little more difficult:
Sub ReformatTable()
    Dim strPage As String
    Dim strMainHeading As String
    Dim strSubHeading As String
    Dim rw As Row
    Dim cl As Cell
    Dim tbl As Table
    Dim r As Integer
    Dim c As Integer
    
    Set tbl = ActiveDocument.Tables(1)
    strPage = tbl.Cell(2, 1).Range.Text
    strMainHeading = tbl.Cell(2, 2).Range.Text
    strSubHeading = tbl.Cell(2, 3).Range.Text
    
    r = 3
    Do
        Set rw = tbl.Rows(r)
        If rw.cells(1).Range.Text = strPage And _
            rw.cells(2).Range.Text = strMainHeading And _
            rw.cells(3).Range.Text = strSubHeading Then
            rw.cells(1).Range.Text = ""
            rw.cells(2).Range.Text = ""
            rw.cells(3).Range.Text = ""

            For c = 1 To tbl.Columns.Count
                Set cl = tbl.Cell(r, c)
                cl.Merge tbl.Cell(r - 1, c)
            Next c
            r = r - 1
        Else
            strPage = rw.cells(1).Range.Text
            strMainHeading = rw.cells(2).Range.Text
            strSubHeading = rw.cells(3).Range.Text
        End If
        r = r + 1
    Loop While r <= tbl.Rows.Count
    
End Sub

Open in new window

0
 
GrahamSkanRetiredCommented:
This macro will combine the cells by removing the borders. It doesn't actully merge the cells. It also removes the repeated text in the three columns.
Option Explicit

Sub ReformatTable()
    Dim strPage As String
    Dim strMainHeading As String
    Dim strSubHeading As String
    Dim rw As Row
    
    strPage = ActiveDocument.Tables(1).Cell(2, 1).Range.Text
    strMainHeading = ActiveDocument.Tables(1).Cell(2, 2).Range.Text
    strSubHeading = ActiveDocument.Tables(1).Cell(2, 3).Range.Text
    
    For Each rw In ActiveDocument.Tables(1).Rows
        If rw.cells(1).RowIndex > 2 Then
            If rw.cells(1).Range.Text = strPage And _
               rw.cells(2).Range.Text = strMainHeading And _
               rw.cells(3).Range.Text = strSubHeading Then
                rw.Borders(wdBorderTop).LineStyle = wdLineStyleNone
                rw.cells(1).Range.Text = ""
                rw.cells(2).Range.Text = ""
                rw.cells(3).Range.Text = ""
            Else
                strPage = rw.cells(1).Range.Text
                strMainHeading = rw.cells(2).Range.Text
                strSubHeading = rw.cells(3).Range.Text
            End If
        End If
    Next rw
    
End Sub

Open in new window

0
 
pdvsaProject financeAuthor Commented:
Hi Graham, that is nice.  I ran it and it does remove the borders.  I do however need to combine into one row.  

I imagine that is difficult?
0
 
pdvsaProject financeAuthor Commented:
wow.  Got some smart people in the UK.   thank you for that!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.