Quote:
Originally Posted by New Daddy
I've already completed a complex table in the landscape page. Is there an easy way to copy Column 1 to Row 1, Column 2 to Row 2, etc? Otherwise, this will turn into a very laborious copy&paste fest.
|
In Word 2010 and later, provided you have the compatibility mode switched off, you can use: Insert>Text Box>Draw Text Box, insert the table into the text box, then rotate the text box. A good reason to upgrade, perhaps. Conversely, that means the table is no longer in the document body, which can affect other things; it also means the table can't span a page boundary.
The following macro rotates a table, clockwise or counter-clockwise in response to user input, as far as practicable preserving column widths, row heights & text formatting:
Code:
Sub RotateTable()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long, x As Long, y As Long, bRotate As Boolean
Dim RngSrc As Range, RngTgt As Range, TblSrc As Table, TblTgt As Table
With Selection
If .Information(wdWithInTable) = True Then
If .Rows.Count > 63 Then
MsgBox "Too many rows - Word only supports up to 63 columns", vbCritical
Exit Sub
End If
Select Case UCase(Left(InputBox("Do you want to rotate the table:" & vbCr & "R = Right (clockwise); or" & vbCr & "L = Left (counter-clockwise)?"), 1))
Case "L": bRotate = True
Case "R": bRotate = False
Case Else: Exit Sub
End Select
Set TblSrc = .Tables(1)
Else
MsgBox vbTab & vbTab & "No Table selected!" & vbCr & _
"Please select some table content before running this macro.", _
vbCritical, "Selection Error"
Exit Sub
End If
End With
With TblSrc
x = .Rows.Count: y = .Columns.Count
With .Range
.Characters.Last.Next.InsertBefore vbCr
.End = .End + 1
End With
End With
Set TblTgt = ActiveDocument.Tables.Add(Range:=TblSrc.Range.Characters.Last.Next, NumRows:=y, NumColumns:=x)
With TblTgt
.Borders = TblSrc.Borders
If bRotate = True Then
For i = 1 To x
For j = 1 To y
Set RngSrc = TblSrc.Cell(i, j).Range: RngSrc.End = RngSrc.End - 1
Set RngTgt = .Cell(j, x - i + 1).Range: RngTgt.End = RngTgt.End - 1
RngTgt.FormattedText = RngSrc.FormattedText
With .Cell(j, x - i + 1)
.BottomPadding = TblSrc.Cell(i, j).RightPadding
.TopPadding = TblSrc.Cell(i, j).LeftPadding
.RightPadding = TblSrc.Cell(i, j).TopPadding
.LeftPadding = TblSrc.Cell(i, j).BottomPadding
End With
Next
Next
On Error Resume Next
For i = 1 To x
.Columns(i).Width = TblSrc.Rows(x - i + 1).Height
If Err.Number = 5149 Then
.Columns(i).AutoFit
Err.Clear
End If
Next
For i = 1 To y
.Rows(i).Height = TblSrc.Columns(i).Width
If Err.Number = 5149 Then
.Rows(i).HeightRule = wdRowHeightAuto
Err.Clear
End If
Next
On Error GoTo 0
.Range.Orientation = wdTextOrientationDownward
ElseIf bRotate = False Then
For i = 1 To x
For j = 1 To y
Set RngSrc = TblSrc.Cell(i, y - j + 1).Range: RngSrc.End = RngSrc.End - 1
Set RngTgt = .Cell(j, i).Range: RngTgt.End = RngTgt.End - 1
RngTgt.FormattedText = RngSrc.FormattedText
With .Cell(j, i)
.BottomPadding = TblSrc.Cell(i, j).LeftPadding
.TopPadding = TblSrc.Cell(i, j).RightPadding
.RightPadding = TblSrc.Cell(i, j).BottomPadding
.LeftPadding = TblSrc.Cell(i, j).TopPadding
End With
Next
Next
On Error Resume Next
For i = 1 To x
.Columns(i).Width = TblSrc.Rows(i).Height
If Err.Number = 5149 Then
.Columns(i).AutoFit
Err.Clear
End If
Next
For i = 1 To y
.Rows(i).Height = TblSrc.Columns(y - i + 1).Width
If Err.Number = 5149 Then
.Rows(i).HeightRule = wdRowHeightAuto
Err.Clear
End If
Next
On Error GoTo 0
.Range.Orientation = wdTextOrientationUpward
End If
End With
TblSrc.Delete
Set RngSrc = Nothing: Set RngTgt = Nothing: Set TblSrc = Nothing: Set TblTgt = Nothing
Application.ScreenUpdating = True
End Sub
Note: The macro does not work with tables containing merged or split cells, and each column must be the same width in all rows. Horizontal starting text is assumed. Ideally, row heights and column widths will be fixed; otherwise they are auto-sized.