vba powerpoint merge cells in loop

问题

I'm trying to put together some code that merges cells where there is duplicate content in the row above. The code works, but once I get to the third row, I get an error that says:

Cell (unknown number): Invalid Request. Cannot merge cells of different sizes.

When I go back to the UI, I can perform the merge manually, so I don'be believe that the cells are different sizes. So I am thinking it is a problem with my code or a limitation of the VBA .Merge method?

Code is below

Sub testMergeDuplicateCells()
Dim oSl As Slide
Dim oSh As Shape
Dim k As Long


slideCount = ActivePresentation.Slides.Count
For k = 3 To (slideCount)
Set oSl = ActivePresentation.Slides(k)

'Start looping through shapes
       For Each oSh In oSl.Shapes
'Now deal with text that is in a table
            If oSh.HasTable Then
                Dim x As Long, z As Long, y As Long
                Dim oText As TextRange
                Dim counter As Long

                counter = 0
                    For x = 17 To oSh.Table.Rows.Count 'will always start on 17th row
                        For z = 1 To oSh.Table.Columns.Count
                        Set oText = oSh.Table.Cell(x, z).Shape.TextFrame.TextRange

                         y = x - 1
                        Set pText = oSh.Table.Cell(y, z).Shape.TextFrame.TextRange

                              If pText = oText Then
                                    With oSh.Table 
                                        .Cell(x + counter, z).Shape.TextFrame.TextRange.Delete
                                        .Cell(y, z).Merge MergeTo:=.Cell(x, z)
                                    End With 
                                    counter = counter + 1
                                End If


                        Next z
                    Next x
        End If

    Next oSh

Next k

End Sub

回答1:

I found the issue and came up with a very in-elegant solution (for now).

First was realizing what the actual dimensions of the cell were. Apparently when PPT does a cell merge it retains the underlying coordinates before the merge. So after I merge Cell (1,1) to Cell (2,1) the cell visually appears as one cell but retains the coordinates of both (1,1) and (2,1).

This utility helped me understand what was the actual underlying construct of my table, by selecting a cell in the UI and having the utility give me the full dimensions.

Sub TableTest()

Dim x As Long
Dim y As Long
Dim oSh As Shape

Set oSh = ActiveWindow.Selection.ShapeRange(1)

With oSh.Table
For x = 1 To .Rows.Count
For y = 1 To .Columns.Count
If .Cell(x, y).Selected Then
Debug.Print "Row " + CStr(x) + " Col " + CStr(y)
End If
Next
Next
End With

End Sub

I then put in a rather in-elegant If statement to have my loop skip to the last column that was part of the set of merged cells, so the Delete and Merge only statement only happened once. The error was introduced when (as Steve pointed out above) the loop looked at the same cell again and interpreted it as having duplicate value across two cells, even though it was one value in a merged cell.

Sub MergeDuplicateCells()
Dim oSl As Slide
Dim oSh As Shape
Dim k As Long

slideCount = ActivePresentation.Slides.Count
For k = 3 To (slideCount)
Set oSl = ActivePresentation.Slides(k)

'Start looping through shapes
       For Each oSh In oSl.Shapes
'Now deal with text that is in a table
            If oSh.HasTable Then
                Dim x As Long, z As Long, y As Long
                Dim oText As TextRange

                        For z = 1 To oSh.Table.Columns.Count
                        'inelegant solution of skipping the loop to the last column
                        'to prevent looping over same merged cell
                        If z = 3 Or z = 6 Or z = 8 Or z = 16 Then
                        For x = 17 To oSh.Table.Rows.Count
                        Set oText = Nothing
                        Set pText = Nothing
                        Set oText = oSh.Table.Cell(x, z).Shape.TextFrame.TextRange

                        If x < oSh.Table.Rows.Count Then

                        y = x + 1
                        Set pText = oSh.Table.Cell(y, z).Shape.TextFrame.TextRange

                              If pText = oText And Not pText = "" Then
                                    With oSh.Table
                                        Debug.Print "Page " + CStr(k) + "Merge Row " + CStr(x) + " Col " + CStr(z) + " with " + "Row " + CStr(y) + " Col " + CStr(z)
                                        .Cell(y, z).Shape.TextFrame.TextRange.Delete
                                        .Cell(x, z).Merge MergeTo:=.Cell(y, z)
                                    End With

                                End If
                        End If

                        Next x
                        End If
                    Next z
        End If
    Next oSh
Next k

End Sub

来源：https://stackoverflow.com/questions/36365559/vba-powerpoint-merge-cells-in-loop

标签

vba

merge

powerpoint