Auto resize cells within table

问题

How do I auto resize the column width or row height in a PowerPoint table?

Edit: I am working with PowerPoint 2010 and I wanted something like:

Sub table_fix()
 Dim icol As Integer, irow As Integer, minW As Single, minH As Single
 With ActiveWindow.Selection.ShapeRange(1).table
  For icol = 1 To .Columns.Count
   For irow = 1 To .Rows.Count
    With .Cell(irow, icol).Shape.TextFrame
     If minW = 0 Then minW = .TextRange.BoundWidth + .MarginLeft + .MarginRight
     If minW < .TextRange.BoundWidth + .MarginLeft + .MarginRight Then minW = .TextRange.BoundWidth + .MarginLeft + .MarginRight
    End With
   Next
   .Columns(icol).Width = minW
  Next
 End With
 With ActiveWindow.Selection.ShapeRange(1).table
  For irow = 1 To .Rows.Count
   For icol = 1 To .Columns.Count
    With .Cell(irow, icol).Shape.TextFrame
     If minH = 0 Then minH = .TextRange.BoundHeight + .MarginTop + .MarginBottom
     If minH < .TextRange.BoundHeight + .MarginTop + .MarginBottom Then minH = .TextRange.BoundHeight + .MarginTop + .MarginBottom
    End With
   Next
   .Rows(irow).Height = minH
  Next
 End With
End Sub

This code does not fix all column widths and all row heights. It has some mess ups on which columns to resize when the columns are narrow and high and it adds random spaces on some numbers sometimes.

I was hoping I could simulate "resizing of a cell through double clicking on the border". I believe I need to have some kind of iteration calculation with BoundWidth and BoundHeight or does 2010 have my originally searched for feature?

Edit 2: I have split the code for testing:

Sub IT()
 Dim icol As Integer, irow As Integer, minW As Single, minH As Single
 Call max_it
 Call size_it
End Sub

Function max_it()
 With ActiveWindow.Selection.ShapeRange(1).table
  For icol = 1 To .Columns.Count
   .Columns(icol).Width = 1000
  Next
 End With
End Function

Function size_it()
 With ActiveWindow.Selection.ShapeRange(1).table
  For icol = 1 To .Columns.Count
   For irow = 1 To .Rows.Count
    With .Cell(irow, icol).Shape.TextFrame
     If minW = 0 Then minW = .TextRange.BoundWidth + .MarginLeft + .MarginRight
     If minW < .TextRange.BoundWidth + .MarginLeft + .MarginRight Then minW = .TextRange.BoundWidth + .MarginLeft + .MarginRight
    End With
   Next
   .Columns(icol).Width = minW
   minW = 0
   If icol < .Columns.Count Then .Columns(icol + 1).Width = 1000
  Next
  For irow = 1 To .Rows.Count
   For icol = 1 To .Columns.Count
    With .Cell(irow, icol).Shape.TextFrame
     If minH = 0 Then minH = .TextRange.BoundHeight + .MarginTop + .MarginBottom
     If minH < .TextRange.BoundHeight + .MarginTop + .MarginBottom Then minH = .TextRange.BoundHeight + .MarginTop + .MarginBottom
    End With
   Next
   .Rows(irow).Height = minH
  Next
 End With
End Function

When I run max_it and size_it separately, it does what I want, but if I call IT to run the two functions after each other it ignores the max_it part and therefore the size_it will not return the correct BoundWidth if the cells are "narrow and high".

I may have some beginner's mistake, like: VBA is smart and realizes that the first max_it changes will be redone by size_it and therefore ignores the code (?)

回答1:

I searched a bit on internet and did some R&D and found this code which worked on a table. The Scenario is that there is a slide and a table in it with a row selected.

Sub Spacer_Row() 'backup
Dim Sld As Slide
Dim Shp As Shape
Dim tabs As table
Dim lRow As Long
Dim lCol As Long
'Table row formatting
On Error GoTo Select_Object
With ActiveWindow.Selection
If .ShapeRange.Type = msoTable Then
Set tabs = .ShapeRange.table
For lRow = 1 To tabs.Rows.Count
 For lCol = 1 To tabs.Columns.Count
  If tabs.Cell(lRow, lCol).Selected Then
   With tabs.Cell(lRow, lCol).Shape
    tabs.Cell(lRow, lCol).Shape.TextFrame2.MarginBottom = 0.7
    tabs.Cell(lRow, lCol).Shape.TextFrame2.MarginTop = 0.6
    tabs.Cell(lRow, lCol).Shape.TextFrame.TextRange.Font.Size = 1
    tabs.Rows(lRow).Height = 0.2
    tabs.Cell(lRow, lCol).Shape.Fill.ForeColor.RGB = RGB(255, 255, 255)
   End With
  End If
 Next
Next
Exit Sub
End If
Select_Object:
 MsgBox "Select a row to resize" 'Error box asking to select a row
End With
End Sub

来源：https://stackoverflow.com/questions/8340726/auto-resize-cells-within-table

标签

powerpoint-vba