VBA Code to copy Text from different rows in one table to a single row in a different table

I had this question after viewing VBA Code to Copy and past text from multiple cells in one table to single cell in a different table.

The question I am asking will be very easy to understand if you look at the image included which shows data in two tables with data after the macro I need runs.

Basically I have two tables in a word document, each with two colums. Column 1 of Table 2 has some Titles, and Column 2 has Data. However, for some Titles there is no data in Column 2.
I would like the macro to copy both Title (from Column 1) and corresponding data from Colum 2, to a single row (Row 2) in Table 2, but only for thoses rows in Table 2 where there is some data in Column 2. That is those rows which only have a Title but not any data in Column 2 will not be copied to the row 2 of Table 1.

The data from the rows in Table 2 will be put in row 2 of Table 1, with a manual line break, but preserving the formating of the data.

Table Diagrams showing data in both tables before and after the macromFor the sake of simplicity I have put only 8 Rows in Table 2. My actual Table 2 can have many more rows than this.
Thank you for your help.
Who is Participating?
GrahamSkanConnect With a Mentor RetiredCommented:
This is modified from my macro offered in answer to your previous question (https://www.experts-exchange.com/questions/29070768/VBA-Code-to-Copy-and-past-text-from-multiple-cells-in-one-table-to-single-cell-in-a-different-table.html)
Option Explicit

Sub TabelToTable()
    Dim tbl1 As Table
    Dim tbl2 As Table
    Dim rng1 As Range
    Dim rng2 As Range
    Dim r1 As Integer
    Dim r2 As Integer
    Set tbl1 = ActiveDocument.Tables(1)
    Set tbl2 = ActiveDocument.Tables(2)
    r1 = 1
    r2 = 1
    Do Until r2 > tbl2.Rows.Count
        Set rng2 = tbl2.Cell(r2, 1).Range
        If Len(rng2) > 2 Then
            rng2.MoveEnd wdCharacter, -1 'drop trailing cell divider
            Set rng1 = tbl1.Cell(r1, 1).Range
            If Len(rng1) > 2 Then 'add a new paragraph if cell not blank
                rng1.Collapse wdCollapseEnd
                rng1.Move wdCharacter, -1
                rng1.InsertAfter vbCr
            End If
            Set rng1 = tbl1.Cell(r1, 1).Range
            rng1.Collapse wdCollapseEnd
            Do While rng1.Cells(1).ColumnIndex > 1
                rng1.MoveEnd wdCharacter, -1 'come back to column 1

        End If
        r2 = r2 + 1
End Sub

Open in new window

NorieVBA ExpertCommented:
So you only want rows that have data in column 2 of Table2 to be copied to Table1?
FaheemAhmadGulAuthor Commented:
Yes please.
Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

FaheemAhmadGulAuthor Commented:
And these all need to be copied and pasted with formatting to row 2 of Table 1
FaheemAhmadGulAuthor Commented:
This code needs some modification as it is not giving the result we need. Please note that in this question (compared to the previous one you answered for me), we need to copy data from the column 2 of Table 2 also. Secondly we do not want to copy data (neither the title nor the data from Colum 2 of Table 2 rows) where there is no data in column 2. If you look at the image the rows with the Title, Super Markets, and Fruits have not been copied and that is because for these 3 rows we do not  have any data in Column 2.
FaheemAhmadGulAuthor Commented:
This solution did not do exactly what my question had asked for, however, it did  give me some ideas through which I was able to solve the problem I was trying to solve.
Many thanks for your help. Greatly appreciated.
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.