VBA Code to Copy and past text from multiple cells in one table to single cell in a different table
My question will be very easy to understand, if you look at the diagram.
I have two tables in my word document. Table 1 has only two rows.
Table 2 has six rows.
I would like to have Macro that will copy text with its formating from from the first cell in Row 2, 3, 5 and 6 of Table 2 to the first cell in Row 2 of the First Table. The text from different cells in Table 2 will be pasted one below the other with manual line breaks.
Thank you for your help.
I have two tables in my word document. Table 1 has only two rows.
Table 2 has six rows.
I would like to have Macro that will copy text with its formating from from the first cell in Row 2, 3, 5 and 6 of Table 2 to the first cell in Row 2 of the First Table. The text from different cells in Table 2 will be pasted one below the other with manual line breaks.
Thank you for your help.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
In answering your next question(https://www.experts-exchange.com/questions/29070873/VBA-Code-to-copy-Text-from-different-rows-in-one-table-to-a-single-row-in-a-different-table.html), I noticed that there was a slight error in the code for this one.
I had started in row 1 for each table, instead of row 2. Here is a correction.
I had started in row 1 for each table, instead of row 2. Here is a correction.
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 = 2
r2 = 2
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
rng2.Copy
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
Loop
rng1.Paste
End If
r2 = r2 + 1
Loop
End Sub
I guess that was the small modification that you mentioned in your last comment (that I have only just noticed).
ASKER
Thank you. Yes, that was the change I also made and after that it works fine.
ASKER