ループ内のVBAパワーポイントのマージセル

Question

私は、上記の行に重複した内容があるセルをマージするコードをまとめようとしています。コードは機能しますが、3行目になるとエラーメッセージが表示されます。

セル（不明な番号）：無効なリクエストです。サイズの異なるセルをマージすることはできません。

私がUIに戻ったとき、私は手動でマージを行うことができるので、セルはさまざまなサイズであるとは思えません。だから私はそれが私のコードやVBAの限界で問題だと思っています。マージメソッド？

コードが

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 

Answer 1

を下回っている私は、問題を発見し、（今のところ）非常にある - エレガントな解決策を考え出しました。

最初に、セルの実際の寸法が何であるかを実現していました。どうやらPPTがセルのマージを行うと、マージの前に元の座標が保持されます。したがって、セル（1,1）をセル（2,1）にマージした後、セルは視覚的に1つのセルとして表示されますが、（1,1）と（2,1）の両方の座標が保持されます。

このユーティリティを使用すると、UIのセルを選択してこのユーティリティを使用することで、実際のテーブルの構造を理解することができました。

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 

声明私のループが結合されたセルのセットの一部であった最後の列にスキップ持っているので、削除だけ文をマージするには、一度だけ起こった場合、私はその後、むしろで、エレガントに入れます。このエラーは、Steveが指摘したように、ループが同じセルをもう一度見て、2つのセル間で重複した値を持つと解釈したときに導入されました。

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