• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 354
  • Last Modified:

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
0
pdvsa
Asked:
pdvsa
  • 2
  • 2
1 Solution
 
GrahamSkanCommented:
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
 
pdvsaAuthor 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
 
GrahamSkanCommented:
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
 
pdvsaAuthor Commented:
wow.  Got some smart people in the UK.   thank you for that!
0

Featured Post

Free Tool: Subnet Calculator

The subnet calculator helps you design networks by taking an IP address and network mask and returning information such as network, broadcast address, and host range.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now