VBA 将范围从 excel 复制到 powerpoint

Question

我正在尝试从 Excel 复制特定范围并将其作为图片粘贴到 pp 中。我从各种在线资源中拼凑了以下代码，并在运行 PowerPointApp.WindowState = 2 时继续收到运行时 91 错误（对象变量或 With 块变量未设置）。

如何修复此错误并避免将来再次出现？

首先我成功运行了

    Private Sub OpenPowerpoint()

        Dim PPT As PowerPoint.Application
        Set PPT = New PowerPoint.Application

        PPT.Visible = True
        PPT.Presentations.Open Filename:="C:\Users\aofarrell\Desktop\CYB\Weekly Pack Update - Template.pptx"
        PPT.ActivePresentation.Slides(2).Select

    End Sub

然后我尝试跑步

 Private Sub CopyToPowerPoint()

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


        'Copy Range from Excel

            Set rng = ThisWorkbook.Sheets("Triggers").Range("B6:Z33")

        'Copy Excel Range
            rng.Copy

        'Paste to PowerPoint and position
            PowerPointApp.WindowState = 2 'ERROR OCCURS HERE
            mySlide.Shapes.PasteSpecial DataType:=0
            Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

        'Set position:
            myShape.Left = 20
            myShape.Top = 70
            myShape.Width = 675
            myShape.Height = 400

        'Clear The Clipboard
            Application.CutCopyMode = False
            Application.Wait (Now + TimeValue("00:00:01"))

        End Sub

Answer 1

嗯...好吧，首先您需要定义您的

Object

是什么类型。你的

PowerPointApp

是什么具体物体。还请记住，局部变量在子/函数末尾被销毁，因此您可能需要一些模块级变量/对象：mySlide

（另外：如果我将 Excel 中的图像复制到 PowerPoint，我通常会使用 

Option Explicit

Private PPT As PowerPoint.Application
Private PPT_pres As PowerPoint.Presentation

Private Sub OpenPowerpoint()
    Set PPT = New PowerPoint.Application

    PPT.Visible = True
    Set PPT_pres = PPT.Presentations.Open(FileName:="C:\Users\aofarrell\Desktop\CYB\Weekly Pack Update - Template.pptx")
    PPT_pres.Slides(2).Select
End Sub

Private Sub CopyToPowerPoint()
    If PPT Is Nothing Then Exit Sub
    If PPT_pres Is Nothing Then Exit Sub

    Dim rng As Range
    Dim mySlide As Object
    Dim myShape As Object

    Set mySlide = PPT_pres.Slides(2)

    'Copy Range from Excel

    Set rng = ThisWorkbook.Sheets("Triggers").Range("B6:Z33")

    'Copy Excel Range
    rng.Copy

    'Paste to PowerPoint and position
    PPT.WindowState = 2
    mySlide.Shapes.PasteSpecial DataType:=0
    Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

    'Set position:
    myShape.Left = 20
    myShape.Top = 70
    myShape.Width = 675
    myShape.Height = 400

    'Clear The Clipboard
    Application.CutCopyMode = False
    Application.Wait (Now + TimeValue("00:00:01"))

End Sub

而不是

Range.CopyPicture xlPrinter

，它会根据您的屏幕分辨率更改图像的大小）

Answer 2

Shapes.PasteSpecial

要运行代码，请按照以下步骤操作：

打开 PowerPoint。

1. 按

Sub CreatePowerPointSlides()
    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    Dim slideTitle As String
    Dim slideContent As String
    Dim slideNum As Integer
    
    ' Create a new PowerPoint application
    Set pptApp = CreateObject("PowerPoint.Application")
    pptApp.Visible = True
    
    ' Create a new presentation
    Set pptPres = pptApp.Presentations.Add
    
    ' Add slides to the presentation
    slideNum = 1
    
    ' Slide 1
    slideTitle = "حلقة لقناتي على يوتيوب"
    slideContent = "تحويل الألم إلى قوة: كيفية استخدام تجاربك السلبية للنمو الشخصي"
    Set pptSlide = pptPres.Slides.Add(slideNum, 1)
    With pptSlide
        .Shapes.Title.TextFrame.TextRange.Text = slideTitle
        .Shapes(2).TextFrame.TextRange.Text = slideContent
    End With
    
    ' Slide 2
    slideNum = slideNum + 1
    slideTitle = "مقدمة"
    slideContent = "في هذه الحلقة، سنتعلم كيفية تحويل الألم والتجارب السلبية إلى قوة وفرصة للنمو الشخصي."
    Set pptSlide = pptPres.Slides.Add(slideNum, 1)
    With pptSlide
        .Shapes.Title.TextFrame.TextRange.Text = slideTitle
        .Shapes(2).TextFrame.TextRange.Text = slideContent
    End With
    
    ' Slide 3
    slideNum = slideNum + 1
    slideTitle = "التحول الشخصي"
    slideContent = "التحول الشخصي هو عملية تغيير النظرة الشخصية للتجارب السلبية واستخدامها كفرصة للنمو والتطور."
    Set pptSlide = pptPres.Slides.Add(slideNum, 1)
    With pptSlide
        .Shapes.Title.TextFrame.TextRange.Text = slideTitle
        .Shapes(2).TextFrame.TextRange.Text = slideContent
    End With
    
    ' Slide 4
    slideNum = slideNum + 1
    slideTitle = "التعامل مع الألم"
    slideContent = "تعلم كيفية التعامل مع الألم والتجارب السلبية بشكل صحيح يمكن أن يساعدك على تحويلها إلى قوة."
    Set pptSlide = pptPres.Slides.Add(slideNum, 1)
    With pptSlide
        .Shapes.Title.TextFrame.TextRange.Text = slideTitle
        .Shapes(2).TextFrame.TextRange.Text = slideContent
    End With
    
    ' Slide 5
    slideNum = slideNum + 1
    slideTitle = "التعلم من التجارب السلبية"
    slideContent = "استخدم التجارب السلبية كفرصة للتعلم والنمو الشخصي، واستخرج الدروس والحكم منها."
    Set pptSlide = pptPres.Slides.Add(slideNum, 1)
    With pptSlide
        .Shapes.Title.TextFrame.TextRange.Text = slideTitle
        .Shapes(2).TextFrame.TextRange.Text = slideContent
    End With
    
    ' Slide 6
    slideNum = slideNum + 1
    slideTitle = "تغيير النظرة الشخصية"
    slideContent = "قم بتغيير نظرتك الشخصية للتجارب السلبية وابحث عن الجوانب الإيجابية والفرص التي يمكن أن تأتي معها."
    Set pptSlide = pptPres.Slides.Add(slideNum, 1)
    With pptSlide
        .Shapes.Title.TextFrame.TextRange.Text = slideTitle
        .Shapes(2).TextFrame.TextRange.Text = slideContent
    End With
    
    ' Slide 7
    slideNum = slideNum + 1
    slideTitle = "التحليل الذاتي"
    slideContent = "قم بتحليل ذاتك واكتشف الأسباب والعوامل التي تؤدي إلى التجارب السلبية، وابحث عن طرق للتغلب عليها."
    Set pptSlide = pptPres.Slides.Add(slideNum, 1)
    With pptSlide
        .Shapes.Title.TextFrame.TextRange.Text = slideTitle
        .Shapes(2).TextFrame.TextRange.Text = slideContent
    End With
    
    ' Slide 8
    slideNum = slideNum + 1
    slideTitle = "التطبيق العملي"
    slideContent = "قم بتطبيق الدروس والتحولات الشخصية التي تعلمتها من التجارب السلبية في حياتك اليومية."
    Set pptSlide = pptPres.Slides.Add(slideNum, 1)
    With pptSlide
        .Shapes.Title.TextFrame.TextRange.Text = slideTitle
        .Shapes(2).TextFrame.TextRange.Text = slideContent
    End With
    
    ' Slide 9
    slideNum = slideNum + 1
    slideTitle = "التأثير الإيجابي"
    slideContent = "استخدم القوة الناشئة من تحويل الألم إلى قوة لتأثير إيجابي على حياتك وحياة الآخرين."
    Set pptSlide = pptPres.Slides.Add(slideNum, 1)
    With pptSlide
        .Shapes.Title.TextFrame.TextRange.Text = slideTitle
        .Shapes(2).TextFrame.TextRange.Text = slideContent
    End With
    
    ' Slide 10
    slideNum = slideNum + 1
    slideTitle = "الاستمرارية والتطور"
    slideContent = "استمر في استخدام تجاربك السلبية للنمو الشخصي والتطور المستمر."
    Set pptSlide = pptPres.Slides.Add(slideNum, 1)
    With pptSlide
        .Shapes.Title.TextFrame.TextRange.Text = slideTitle
        .Shapes(2).TextFrame.TextRange.Text = slideContent
    End With
    
    ' Clean up
    Set pptSlide = Nothing
    Set pptPres = Nothing
    Set pptApp = Nothing
    
    MsgBox "PowerPoint slides created successfully!"
End Sub

2. 打开 VBA 编辑器。插入新模块。
3. 将上述代码复制并粘贴到模块中。
4. 运行
Alt + F11
5. 宏。
此代码将创建一个新的 PowerPoint 演示文稿，其中包含 10 张阿拉伯语幻灯片，每张幻灯片都包含基于您的想法的标题和内容。