Копирование и вставка из Excel в PowerPoint с использованием VBA

Question

У меня есть имена определенных столбцов в Excel, которые я хочу скопировать и вставить в PowerPoint, но я не могу запустить код, потому что я получаю «Run Error 424.» Я попытался использовать ("B3: Q3") для столбцов, и это работает. Однако мне не нужны все эти столбцы, мне нужны только столбцы, перечисленные ниже («b3, f3, l3, n3, p3, q3»). Кто-нибудь может помочь? Большое вам спасибо!

Sub ExcelRangeToPowerPoint()

Dim rng As Range
Dim rng1 As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object

'Copy Range from Excel
  Set rng = ThisWorkbook.ActiveSheet.Range("b3,f3,l3,n3,p3,q3").Select 'THIS IS THE ERROR
  Set rng1 = ThisWorkbook.ActiveSheet.Range("G4:I4")

'Create an Instance of PowerPoint
  On Error Resume Next

    'Is PowerPoint already opened?
      Set PowerPointApp = GetObject(class:="PowerPoint.Application")

    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then open PowerPoint
      If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If

  On Error GoTo 0

'Optimize Code
  Application.ScreenUpdating = False

'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add

'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly

'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=7  '7 = ppPasteText
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set position:rng
  myShape.Left = 70
  myShape.Top = 150
  myShape.Width = 800
  myShape.Height = 100

'Copy Excel Range
  rng1.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial DataType:=7  '7 = ppPasteText
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set position:rng
  myShape.Left = 70
  myShape.Top = 200
  myShape.Width = 800
  myShape.Height = 300

'Insert the tile on the ppt
mySlide.Shapes.Title.TextFrame.TextRange.Text = "Insert Title Here"

'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub

Answer 1

Снимите .Select.

1) Вы не можете Set Rng = [whatever].Select. Вы хотите сделать Set Rng = [whatever] затем Rng.Select на новой строке, но, что более важно,

2) Лучше всего Избегать использования .Select / .Activate. Хотя вы, кажется, не используете его в другом месте (хорошо!), Поэтому держу пари, что это просто "опечатка".

Кроме того, если вы хотите Столбцы , вы должны сделать:

Set rng = ThisWorkbook.ActiveSheet.Range("b3,f3,l3,n3,p3,q3").EntireColumn

Редактировать: Это не решит проблему вставки промежуточных столбцов, но этот (по общему признанию немного хитрый) код выберет только используемые данные (включая заголовки) вместо целых столбцов:

 'Copy Range from Excel
  Dim lastRow As Long
  With ThisWorkbook.ActiveSheet

    lastRow = .Cells(Rows.Count, 2).End(xlUp).Row
    ' I assume your headers actually are in row 3, and the data is in row 4 on ward:
    Set rng = ThisWorkbook.ActiveSheet.Range("b3:B" & lastRow & ",f3:F" & lastRow & ",l3:l" & lastRow & ",n3:N" & lastRow & ",p3:P" & lastRow & ",q3:Q" & lastRow)
    Set rng1 = ThisWorkbook.ActiveSheet.Range("G4:I4")
  End With
 'Create an Instance of PowerPoint
  On Error Resume Next
 ' Etc. etc.