VBA Powerpoint合并循环中的单元格 [英] 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:

单元格(未知数字):无效的请求.无法合并大小不同的单元格.

当我返回UI时，我可以手动执行合并，因此我不相信单元格的大小不同.所以我认为这是我的代码有问题还是VBA .Merge方法的局限性?

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?

代码在下面

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

推荐答案

我发现了这个问题，并提出了一个非常优雅的解决方案(目前).

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

首先要意识到电池的实际尺寸.显然，当PPT进行单元合并时，它会在合并之前保留基础坐标.因此，在将单元格(1,1)合并到单元格(2,1)后，该单元格在视觉上显示为一个单元格，但保留了(1,1)和(2,1)的坐标.

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).

通过在UI中选择一个单元格并让该实用程序为我提供完整的尺寸，此实用程序帮助我了解了表的实际底层构造.

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

然后，我输入了一个不太雅致的If语句，使我的循环跳到合并单元格集合中的最后一列，因此，仅Delete and Merge语句仅发生一次.当循环(如史蒂夫(Steve)所指出的)再次出现时，引入了错误，即使该循环在合并的单元格中是一个值，也将其解释为在两个单元格中具有重复的值.

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

这篇关于VBA Powerpoint合并循环中的单元格的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！