Использование CommandBars.ExecuteMso проблемы

Question

Berry - это диапазон нескольких ячеек из другого файла excel, а Melon - таблица слайдов PowerPoint. Я пытаюсь вставить Berry в таблицу ppt, сначала выбрав ячейку (3,2) в таблице ppt. Сделав это, я хотел бы отменить выбор. и выберите ячейку (3.7).

Следующий код успешно вставляет диапазон в таблицу с ячейкой (3,2) в верхнем левом углу.

Berry.Copy 
Melon.Table.Cell(3, 2).Shape.Select 

Lemon.CommandBars.ExecuteMso ("PasteExcelTableDestinationTableStyle") 

Однако, когда я пытаюсь следующий код, диапазон получает вставить в таблицу с Cell (3,7) в верхнем левом углу. Я бы подумал, что диапазон будет вставлен в соответствии с предыдущим, а затем просто выберите ячейку (3,7) без вставки.

Berry.Copy 
Melon.Table.Cell(3, 2).Shape.Select 

Lemon.CommandBars.ExecuteMso ("PasteExcelTableDestinationTableStyle") 

Melon.Table.Cell(3, 7).Shape.Select 

Кажется, что код ExecuteMso всегда выполняется как последняя строка кода. Простите мой английский, и я благодарю вас за ваше время и помощь.

Ниже приведен полный код:

Sub Auto() 

Application.CutCopyMode = False 
Dim apple As Workbook 
Dim grape As Workbook 
Dim orange As Range 
Dim Kiwi As Shape 'Shape 
Dim Peach As Object 
Dim Berry As Range 
Dim pear As Range 
Dim Lemon As PowerPoint.Application 'PPApp 
Dim LemonJuice As PowerPoint.Presentation 'PPpres 
Dim Melon As PowerPoint.Shape 
Dim LCounter As Integer 


Set grape = Workbooks.Open(Filename:="C:\Users\206521654\Documents\Automate  vba\try.xlsx") 
Set apple = Workbooks.Open(Filename:="C:\Users\206521654\Documents\Automate vba\Monthly Report\Msia\Weekly Channel Ranking Broken Out.xlsx") 
Set orange = apple.Sheets("Periods").Range("A5:C25") 
orange.Copy 
grape.Sheets("Sheet1").Range("B3:D23").PasteSpecial xlPasteValues 

grape.Sheets("Sheet1").Range("E3").Formula = "=D3/C3-1" 

Set SourceRange = grape.Sheets("Sheet1").Range("E3") 
Set fillRange = grape.Sheets("Sheet1").Range("E3:E23") 
SourceRange.AutoFill Destination:=fillRange 
grape.Sheets("Sheet1").Range("E3:E23").NumberFormat = "0%" 

grape.Sheets("Sheet1").Range("B3:E23").Font.Name = "Calibri" 
grape.Sheets("Sheet1").Range("B3:E23").Font.Size = "11" 
grape.Sheets("Sheet1").Range("C3:D23").NumberFormat = "0.000" 
For Each Cell In grape.Sheets("Sheet1").Range("E3:E23") 
If Cell.Value < 0 Then 
    Cell.Font.Color = vbRed 
Else: 
    Cell.Font.Color = vbBlue 
End If 
Next 
Set Berry = grape.Sheets("Sheet1").Range("B3:E23") 
Berry.Copy 

Set Lemon = New PowerPoint.Application 

Set LemonJuice = Lemon.Presentations.Open("C:\Users\206521654\Documents\Automate vba\Automate test.pptx") 


Set Melon = LemonJuice.Slides(1).Shapes(8) 

Melon.Table.Cell(3, 2).Shape.Select 
Lemon.CommandBars.ExecuteMso "PasteExcelTableDestinationTableStyle" 


Melon.Table.Cell(7, 2).Shape.Select 

End Sub 

Answer 1

Так вот пример кода, который принимает открытый документ первенствовать и открыть PowerPoint и копирует данные таблицы из Excel в новую таблицу в PowerPoint.

Вам MUST добавить ссылку на ваш Powerpoint Excel VBA.

Поместите что-то в ячейки 2,2 и 2,3 в excel, оно должно быть вставлено в новый стол в powerpoint.

Примечание: Поскольку я просто пюре кучи кода из документации вместе, вы получаете некоторые ненужные функции, такие как создание новой таблицы каждый раз, и изменения всех таблиц, но я надеюсь, что этот код служит необходимой базой для того, чтобы показать вам, как вы можете избежать использования msoExecute.

Option Explicit 

Sub TestCopyData() 

Dim sSht As Worksheet 
Set sSht = ActiveWorkbook.Sheets("Sheet1") 

Dim PPApp As PowerPoint.Application 
Dim PPPres As PowerPoint.Presentation 
Dim PPSlide As PowerPoint.Slide 


'Open PPT if not running, otherwise select active instance 
On Error Resume Next 
Set PPApp = GetObject(, "PowerPoint.Application") 
On Error GoTo 0 
If PPApp Is Nothing Then 
    'Open PowerPoint 
    Set PPApp = CreateObject("PowerPoint.Application") 
    PPApp.Visible = True 
End If 

PPApp.ActivePresentation.Slides(1).Shapes _ 
    .AddTable NumRows:=3, NumColumns:=4, Left:=10, _ 
    Top:=10, Width:=288, Height:=288 

Dim sh As Integer 
Dim col As PowerPoint.Column 
With PPApp.ActivePresentation.Slides(1) 
    For sh = 1 To .Shapes.Count 
     If .Shapes(sh).HasTable Then 
      For Each col In .Shapes(sh).Table.Columns 
       Dim cl As PowerPoint.Cell 
       For Each cl In .Shapes(sh).Table.Rows(2).Cells 
        cl.Shape.Fill.ForeColor.RGB = RGB(50, 125, 0) 
       Next cl 
       .Shapes(sh).Table.Columns(1).Width = 110 
       .Shapes(sh).Table.Cell(2, 1).Shape.TextFrame.TextRange.Text = sSht.Cells(2, 2) 
       .Shapes(sh).Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = sSht.Cells(2, 3) 
      Next col 
     End If 
    Next 
End With 

End Sub