Table formatting for two rows

[RayKay]

Hi John, I've created the below code from various sources I edited and merged. I'm really impressed how I've improved since I first started back in December, so thanks for your advice and coding in the past :)

However, I'm stumped on how to:

i. Top two rows to be bold text
ii. Top row to be merged (no matter how many cells in that row)
iii. Left Indent of first row is 0 (the rest are correct at '5' in the code below)

Otherwise the code runs perfectly!

Thank you :)

Code:


Public Sub ConvertTable()


Dim tbl As table
Dim icol As Integer
Dim irow As Integer
Dim I As Integer


Dim shp As Shape
For Each shp In ActiveWindow.Selection.SlideRange.Shapes
With shp
If .HasTable Then .Select
End With
Next shp


Dim x As Integer
Dim y As Integer
Dim otbl As table
Dim B As Long
On Error GoTo err:
Set otbl = ActiveWindow.Selection.ShapeRange(1).table
otbl.Parent.Height = 0
For x = 1 To otbl.Columns.Count
For y = 1 To otbl.Rows.Count
With otbl.Cell(y, x)
If .Selected Then
.Shape.TextFrame2.MarginLeft = 5
.Shape.TextFrame2.MarginRight = 5
.Shape.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Shape.TextFrame2.TextRange.Font.Size = 12
.Shape.TextFrame2.TextRange.Font.Name = "Arial"
.Shape.TextFrame2.TextRange.Font.Bold = msoFalse
.Shape.TextFrame2.VerticalAnchor = msoAnchorTop
.Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
End If
End With
Next 'y
Next 'x


With ActiveWindow.Selection.ShapeRange(1).table
With .Cell(1, 1).Shape
With .TextFrame2.TextRange
.Text = "Table Heading"
End With
End With
End With
With ActiveWindow.Selection.ShapeRange(1).table
With .Cell(2, 2).Shape
With .TextFrame2.TextRange
.Text = "Column Headings"
End With
End With
End With
End Sub

[John Wilson]

This should give you something to start working on :

Sub ConvertTable()
Dim otbl As Table
Dim icol As Integer
Dim irow As Integer
Dim I As Integer
Dim colCount As Long
Dim x As Integer
Dim y As Integer
Dim B As Long




Dim shp As Shape
For Each shp In ActiveWindow.Selection.SlideRange.Shapes
If shp.HasTable Then
Set otbl = shp.Table
End If
Next shp
colCount = otbl.Columns.Count


otbl.Parent.Height = 0
For x = 1 To otbl.Columns.Count
For y = 1 To otbl.Rows.Count
With otbl.Cell(y, x)
.Shape.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)
.Shape.TextFrame2.TextRange.Font.Size = 12
.Shape.TextFrame2.TextRange.Font.Name = "Arial"
.Shape.TextFrame2.VerticalAnchor = msoAnchorTop
.Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
Select Case y
Case Is = 1, 2
.Shape.TextFrame2.MarginLeft = 0
.Shape.TextFrame2.MarginRight = 0
.Shape.TextFrame2.TextRange.Font.Bold = msoTrue
Case Else
.Shape.TextFrame2.MarginLeft = 5
.Shape.TextFrame2.MarginRight = 5
.Shape.TextFrame2.TextRange.Font.Bold = msoFalse
End Select
End With
Next 'y
Next 'x




With otbl
With .Cell(1, 1).Shape
With .TextFrame2.TextRange
.Text = "Table Heading"
End With
End With
End With
With ActiveWindow.Selection.ShapeRange(1).Table
With .Cell(2, 2).Shape
With .TextFrame2.TextRange
.Text = "Column Headings"
End With
End With
End With
'merge cells
otbl.Cell(1, 1).Merge otbl.Cell(2, colCount)
End Sub




After you have merged cells you will find they sometimes do not act as expected in code!

[RayKay]

Thank you so much! If someone uses the tool a second time, then it carries on merging of course, so to save that happening I've removed the merge feature and state merge cells manually, then the tool can be clicked any amount of times and the merged row isn't affected! Perfect coding, thank you once again :)