Consulting

Results 1 to 3 of 3

Thread: Table formatting for two rows

  1. #1
    VBAX Regular
    Joined
    Dec 2018
    Posts
    75
    Location

    Table formatting for two rows

    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

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,816
    Location
    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!
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    VBAX Regular
    Joined
    Dec 2018
    Posts
    75
    Location
    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

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •