Question

我正在编写一个代码，使用VBA将数据从Excel写入Powerpoint，我正在使用SpreadSheetGuru.com提供的资源。目前我有多个子读取每个excel页面的数据并将其复制/粘贴到Powerpoint。运行每个单独的子程序会使程序运行正常，但是当我调用子程序时程序崩溃。我粗体并强调Sub Rev中的代码行导致代码崩溃。我昨天问过这个问题，但似乎每次都会出现更多问题，而我似乎要陷入一个兔子洞。

所以这里是调用函数：我使用了Sleep和DoEvents的混合来保持VBA和Windows同步，但问题仍然存在：

Sub Run_All()

Dim StartTime As Double
Dim SecondsElapsed As Double
Application.ScreenUpdating = False


StartTime = Timer
DoEvents
Call SO_AMButton
DoEvents
SecondsElapsed = Round(Timer - StartTime, 2)
Worksheets("SOS Overview").Range("AA23").Value = SecondsElapsed


Sleep (6000)
StartTime = Timer
DoEvents
Call Rev_OverBtn
SecondsElapsed = Round(Timer - StartTime, 2)
DoEvents
Worksheets("SOS Overview").Range("AA25").Value = SecondsElapsed
End Sub

这是SO_AMButton中提供的代码，我知道它有点混乱，但很大程度上是由于各种实验：

Sub SO_AMButton()

'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com


    Dim rng As Range
Dim graph As ChartObject
Dim i As Integer
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object


'Copy Range from Excel
Dim w As Worksheet: Set w = Sheets("SOS Overview")
Set rng = w.Range("AE4:AJ5") 


'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


'Create a New Presentation
  Set myPresentation = PowerPointApp.ActivePresentation


'Add a slide to the Presentation
  Set mySlide = myPresentation.Slides(3)
  mySlide.Select


'Copy Excel Range
  rng.Copy

'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (700)

    'Set position:
      myShape.Left = 110
      Sleep (200)
      myShape.Top = 83
      Sleep (200)
      myShape.Width = 500
      Sleep (200)
      myShape.Height = 50
      Sleep (200)


Application.CutCopyMode = False
Sleep (200)


'Copy Range from Excel

  Set rng = w.Range("c5:e8")
  DoEvents

  '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


'Copy Excel Range
  rng.Copy
  DoEvents


'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (700)

    'Set position:
      myShape.Left = 27
      DoEvents
      myShape.Top = 134
      DoEvents
      myShape.Width = 120
      DoEvents
      myShape.Height = 130
      DoEvents


Application.CutCopyMode = False
DoEvents


'Copy Range from Excel


  Set rng = w.Range("k5:o9")
  DoEvents


'Create an Instance of PowerPoint
  On Error Resume Next

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

    '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



'Copy Excel Range
  rng.Copy
  DoEvents




'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
  DoEvents
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  DoEvents

    'Set position:
      myShape.Left = 170
      DoEvents
      myShape.Top = 134
      DoEvents
      myShape.Width = 240
      DoEvents
      myShape.Height = 130
      DoEvents


Application.CutCopyMode = False
DoEvents


 Set rng = w.Range("X12:AC16")
 DoEvents


'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





'Copy Excel Range
  rng.Copy




'Paste to PowerPoint and position
  mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
  Sleep (200)
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (200)

    'Set position:
      myShape.Left = 420
      Sleep (200)
      myShape.Top = 134
      Sleep (200)
      myShape.Width = 292
      Sleep (200)
      myShape.Height = 85
      Sleep (200)


Application.CutCopyMode = False
Sleep (200)


Set graph = w.ChartObjects("Weekday Morning")
Sleep (200)


graph.Copy
Sleep (200)




mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
Sleep (700)
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (200)


      myShape.Left = 430
      Sleep (200)
      myShape.Top = 210
      Sleep (200)
      myShape.Width = 283
      Sleep (200)
      myShape.Height = 140
      Sleep (200)


Application.CutCopyMode = False
Sleep (200)


Set graph = w.ChartObjects("Hours Morning") 
Sleep (200)


graph.Copy
Sleep (200)




mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
Sleep (200)
Sleep (700)
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (700)


      myShape.Left = 430
      Sleep (200)
      myShape.Top = 350
      Sleep (200)
      myShape.Width = 283
      Sleep (200)
      myShape.Height = 140
      Sleep (200)


Application.CutCopyMode = False
Sleep (200)


Set graph = w.ChartObjects("ATT Morning") 
Sleep (200)


graph.Copy
Sleep (200)


Application.Wait (Now + TimeValue("0:00:01"))
Sleep (200)


mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
Sleep (700)
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (200)


Application.Wait (Now + TimeValue("0:00:01"))




      myShape.Left = 27
      Sleep (200)
      myShape.Top = 270
      Sleep (200)
      myShape.Width = 380
      Sleep (200)
      myShape.Height = 220
      Sleep (200)


Application.CutCopyMode = False
Sleep (200)


ActiveWorkbook.Worksheets("SOS Overview").Range("AA21").Value = 1
Sleep (200)


End Sub

虽然这是Sub Rev的代码：

Sub Rev_OverBtn()

'PURPOSE: Copy/Paste An Excel Range Into a New PowerPoint Presentation
'SOURCE: www.TheSpreadsheetGuru.com


Dim rng As Range
Dim graph As ChartObject
Dim i As Integer
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide2 As Object
Dim myShape As Object


'Copy Range from Excel
Dim w1 As Worksheet: Set w1 = Sheets("REV Overview")
Set rng = w1.Range("AR40:AT41") 


'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


'Create a New Presentation
  Set myPresentation = PowerPointApp.ActivePresentation


'Add a slide to the Presentation
  Set mySlide2 = myPresentation.Slides(5)
  mySlide2.Select


'Copy Excel Range
  rng.Copy

  Application.Wait (Now + TimeValue("0:00:01"))

'Paste to PowerPoint and position
  ***mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)***

  Application.Wait (Now + TimeValue("0:00:04"))

    'Set position:
      myShape.Left = 110
      myShape.Top = 70
      myShape.Width = 500
      myShape.Height = 50


Application.CutCopyMode = False


'Copy Range from Excel
  Set rng = w1.Range("G11:I18")

  '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





'Copy Excel Range
  rng.Copy


Set mySlide2 = myPresentation.Slides(5)


'Paste to PowerPoint and position
  mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)

    'Set position:
      myShape.Left = 27
      myShape.Top = 134
      myShape.Width = 120
      myShape.Height = 130


Application.CutCopyMode = False


'Copy Range from Excel
  Set rng = w1.Range("G4:M8") 


'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

Set mySlide2 = myPresentation.Slides(5)




'Copy Excel Range
  rng.Copy


For i = 1 To 1
   'milliseconds
Next i


'Paste to PowerPoint and position
  mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)

    'Set position:
      myShape.Left = 170
      myShape.Top = 134
      myShape.Width = 280
      myShape.Height = 130


Application.CutCopyMode = False


'Copy Range from Excel
  Worksheets("REV Overview").Activate
  Set rng = w1.Range("AG37:AJ45") 


'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


'Create a New Presentation
  Set myPresentation = PowerPointApp.ActivePresentation




'Copy Excel Range
  rng.Copy




'Paste to PowerPoint and position
  mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)

    'Set position:
      myShape.Left = 460
      myShape.Top = 134
      myShape.Width = 250
      myShape.Height = 129

   Application.CutCopyMode = False

'Copy Range from Excel
  Worksheets("REV Overview").Activate
  Set rng = w1.Range("AM37:AP48")


'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






'Copy Excel Range
  rng.Copy




'Paste to PowerPoint and position
  mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)

    'Set position:
      myShape.Left = 460
      myShape.Top = 270
      myShape.Width = 250
      myShape.Height = 214


Application.CutCopyMode = False


Set graph = w1.ChartObjects("BS") ' BS Graph


graph.Copy




mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)


      myShape.Left = 27
      myShape.Top = 270
      myShape.Width = 200
      myShape.Height = 214


Application.CutCopyMode = False


Set graph = w1.ChartObjects("FS") 'FS Graph


graph.Copy




mySlide2.Shapes.PasteSpecial ppPasteBitmap    '2 = ppPasteEnhancedMetafile
  Set myShape = mySlide2.Shapes(mySlide2.Shapes.Count)


      myShape.Left = 250
      myShape.Top = 270
      myShape.Width = 200
      myShape.Height = 214

Application.CutCopyMode = False


End Sub

Answer 1

所以我评估了错误并将其分区为复制和粘贴图形。我改变了复制和粘贴图形的旧格式：

Set graph = w.ChartObjects("OSAT Graph") 
Sleep (200)
graph.Copy
Sleep (200)
Application.Wait (Now + TimeValue("0:00:01"))
Sleep (200)
mySlide.Shapes.PasteSpecial ppPasteEnhancedMetafile    '2 = ppPasteEnhancedMetafile
Sleep (700)
  Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
  Sleep (200)

Application.Wait (Now + TimeValue("0:00:01"))

      myShape.Left = 27
      Sleep (200)
      myShape.Top = 270
      Sleep (200)
      myShape.Width = 380
      Sleep (200)
      myShape.Height = 220
      Sleep (200)

Application.CutCopyMode = False
Sleep (200)

要：

Set graph = ActiveSheet.ChartObjects("OSAT Graph") 
graph.Chart.CopyPicture
Set myShape = mySlide.Shapes.PasteSpecial(DataType:=ppPasteBitmap)
With myShape(1)
    .LockAspectRatio = False
    .Left = 27
    .Top = 334
    .Width = 367
    .Height = 157
End With

通过粘贴分辨率较低的图形，代码现在可以正常工作而不会出现任何错误。谢谢大家的帮助！

单个Sub运行正常，但一起调用它们会导致程序崩溃（同样调试工作正常）

1 个答案: