Excel VBA：Excelのセルをパワーポイントに貼り付けたい

Question

Excelのセルをパワーポイントにビットマップ形式で貼り付けたいのですが、
複数ページあり、何故かパワポの2枚目に貼りついてくれません（どうしても
1枚目に貼りつきます）。
選択されているスライドにビットマップ形式で貼り付けるにはどうすれば良いか
お分かりの方いらっしゃるでしょうか？

以下、準備です。
１．パワポはデスクトップに「sample.pptx」で保存しています。
２．パワポは、標準（4:3）で、デフォルトはスライド「なし」の状態です。
３．エクセルは、セルA5、A10、A15に「会社名」と入力。「会社名」の下でページを
改行する感じです。
４．A21にスペースを入力しています。このスペースをキーにして、マクロを終了しています。

以下、コードです

Sub PPTにコピペ()
Dim tpp As PowerPoint.Application
Dim newtpp As Object
Dim sl As PowerPoint.Slide
Dim countSld As Integer
Dim ppPt As Presentation
Dim ws As Worksheet
Dim ppApp As New PowerPoint.Application

shito = ActiveSheet.Name

Set ppPt = ppApp.Presentations.Open(ThisWorkbook.Path & "\sample.pptx")

Set sl = ppPt.Slides.Add(1, ppLayoutBlank)

'PowerPointを表示
ppPt.PageSetup.SlideSize = ppSlideSizeOnScreen '標準（4:3）
'
'
Range("B5").Select
a = ActiveCell
b = Left(a, 8)
LT_Row = 10 'LT→Left_top
LT_Col = 2
RL_Col = 88 'RL→Right_low
'
Do Until ActiveCell = " "
If b = "会社名" Then
If ActiveCell.Font.ColorIndex = 2 Then
RL_Row = ActiveCell.Row + 1
Range(Cells(LT_Row, LT_Col), Cells(RL_Row, RL_Col)).Select
Selection.Copy
'
sl.Select 'PowerPointをを選択

       sl.Shapes.PasteSpecial DataType:=ppPasteBitmap, Link:=msoFalse  '表を貼り付け
       '位置を調整
       sl.Shapes(1).LockAspectRatio = msoFalse
       sl.Shapes(1).Left = 1
       sl.Shapes(1).Top = 1
       sl.Shapes(1).Width = 718
       sl.Shapes(1).Height = 538

       With ppPt.Slides  'スライドを追加
           .Add _
           Index:=.Count + 1, _
           Layout:=ppLayoutText
       End With

'
'
countSld = ppPt.Slides.Count
ppPt.Slides.Item(countSld).Select 'n枚目のスライドを選択
Cells(RL_Row + 25, 2).Select
'
a = ActiveCell
b = Left(a, 8)
End If ''If b = "会社名" Then
'
'
If ActiveCell.Font.ColorIndex = 1 And b = "会社名" Then
LT_Row = RL_Row + 1
RL_Row = ActiveCell.Row
Range(Cells(LT_Row, LT_Col), Cells(RL_Row, RL_Col)).Select

   Selection.Copy

'
sl.Select 'PowerPointをを選択

       sl.Shapes.PasteSpecial DataType:=ppPasteBitmap, Link:=msoFalse  '表を貼り付け
       '位置を調整
       sl.Shapes(1).LockAspectRatio = msoFalse
       sl.Shapes(1).Left = 1
       sl.Shapes(1).Top = 1
       sl.Shapes(1).Width = 718
       sl.Shapes(1).Height = 538

       With ppPt.Slides  'スライドを追加
           .Add _
           Index:=.Count + 1, _
           Layout:=ppLayoutText
       End With

'
'
countSld = ppPt.Slides.Count
ppPt.Slides.Item(countSld).Select 'n枚目のスライドを選択
Cells(RL_Row + 3, 2).Select
'
a = ActiveCell
b = Left(a, 8)
'
End If 'If ActiveCell.Font.ColorIndex = 1 And b = "会社名" Then

End If 'If b = "会社名" Then

ActiveCell.Offset(1, 0).Activate
a = ActiveCell
b = Left(a, 8)

Loop
'
'
ppPt.Slides.Item(1).Select '1枚目のスライドを選択
Set ppPt = Nothing
Set tpp = Nothing

End Sub

Answer 1

ppPt.Slides.Item(countSld).Select 'n枚目のスライドを選択　したあとで

sl.Select   'また1ページ目を選択しているから？

With ppPt.Slides  'スライドを追加　するときにslを再セットしたらどうでしょう。
  Set sl = .Add(Index:=.Count + 1, Layout:=ppLayoutText)
End With

Comments

[koneko-neko]

jinoji様、
返信ありがとうございます。
sl.Select
を外したら、貼り付くようになったのですが、下記が機能しなくなりました。

'位置を調整
sl.Shapes(1).LockAspectRatio = msoFalse
sl.Shapes(1).Left = 1
sl.Shapes(1).Top = 1
sl.Shapes(1).Width = 718
sl.Shapes(1).Height = 538

貼り付けた図を選択するにはどうすれば良いでしょうか？

[jinoji]

sl.Selectを外すのではなく、
追加したスライドをslにセット→slを選択→slに貼り付け→貼り付けた図の位置を調節→
を繰り返す感じになればいいような気がします。

Set sl = ppPt.Slides.Add(.......)
sl.Select
sl.PasteSpecial .....
sl.Shape(1).....

[koneko-neko]

jinoji様、
解決いたしました。
おそらく、
Set sl = .Add(Index:=.Count + 1, Layout:=ppLayoutText)
End With
の部分で、「ppLayoutText」としているところで、「Shape（1）を選択するんだよね？」となっていたようで（貼り付けた画像はShape(3)でした。）、「ppLayoutBlank」に変えたら、該当の画像を選択してくれて、サイズも変わってくれました。
ありがとうございました！

[jinoji]

なるほど。
ppLayoutTextだと元々タイトルとサブタイトルのShapeがあるので
そこに貼り付けると３番目になるという理屈でしょうかね。
解決したようでよかったです。