View Single Post
 
Old 02-16-2021, 11:36 PM
Cendrinne's Avatar
Cendrinne Cendrinne is offline Windows 10 Office 2019
Competent Performer
 
Join Date: Aug 2019
Location: Montreal Quebec Canada
Posts: 190
Cendrinne is on a distinguished road
Default

I had to fix something, sorry for the delay

Code:
Sub T1fr_Merge_2Col_Vertically_in_1_col_TST()
'This macro is to have every row in each column, under each other, as 1 column

Application.ScreenUpdating = False

' Select column l, then go to Column 2
    Selection.SelectColumn
    Selection.MoveRight Unit:=wdCell
    Selection.MoveRight Unit:=wdCharacter, Count:=1
    Selection.MoveRight Unit:=wdCell
    Selection.EndKey Unit:=wdRow, Extend:=True
    Selection.EndKey Unit:=wdColumn, Extend:=True

'Select column 2, Cut then paste below table 1
    Selection.Copy
    Selection.Cut
    Selection.EndKey Unit:=wdColumn, Extend:=True
    Selection.MoveDown Unit:=wdLine, Count:=1
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.PasteAndFormat (wdFormatOriginalFormatting)
    Selection.MoveUp Unit:=wdLine, Count:=1
    Selection.HomeKey Unit:=wdRow, Extend:=True
    Selection.HomeKey Unit:=wdColumn, Extend:=True
    Selection.MoveRight Unit:=wdCell
    Selection.MoveRight Unit:=wdCell
    Selection.EndKey Unit:=wdRow, Extend:=True
    Selection.EndKey Unit:=wdColumn, Extend:=True

'  Remove extra paragraph marks to get all tables as 1
    Selection.MoveUp Unit:=wdLine, Count:=1
    Selection.HomeKey Unit:=wdColumn
    Selection.MoveUp Unit:=wdLine, Count:=1
    Selection.Delete Unit:=wdCharacter, Count:=1
    Selection.MoveUp Unit:=wdLine, Count:=1
    Selection.Delete Unit:=wdCharacter, Count:=1
    
'Resize the whole table as 1 column, page wide
    Selection.Tables(1).Select
    Selection.Rows.ConvertToText Separator:=wdSeparateByParagraphs, _
        NestedTables:=False
    Selection.ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, _
         NumRows:=31, AutoFitBehavior:=wdAutoFitFixed

Application.ScreenUpdating = True
    
    On Error GoTo 0
End Sub
Reply With Quote