Vba 运行时错误1004';应用程序定义或对象定义错误';将使用范围的工作表粘贴到powerpoint幻灯片时

Vba 运行时错误1004';应用程序定义或对象定义错误';将使用范围的工作表粘贴到powerpoint幻灯片时,vba,excel,ms-office,powerpoint,Vba,Excel,Ms Office,Powerpoint,我有一个Excel工作表,可以将模板工作表复制到新工作表中。在前两次迭代中,它运行并将使用的范围粘贴到Powerpoint的特定幻灯片中,但在第三次迭代中,它在这行代码中抛出以下错误 运行时错误1004应用程序定义或对象定义错误 PPslide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile Set myshape = PPslide.Shapes(PPslide.Shapes.Count) 我的代码: Private

我有一个Excel工作表,可以将模板工作表复制到新工作表中。在前两次迭代中,它运行并将使用的范围粘贴到Powerpoint的特定幻灯片中,但在第三次迭代中,它在这行代码中抛出以下错误

运行时错误1004应用程序定义或对象定义错误

PPslide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myshape = PPslide.Shapes(PPslide.Shapes.Count)
我的代码:

Private Sub CommandButton2_Click()

Dim PP As PowerPoint.Application
Dim PPpres As Object
Dim PPslide As Object
Dim PpTextbox As PowerPoint.Shape
Dim SlideTitle As String
Dim SlideNum As Integer
Dim WSrow As Long
Dim Sh As Shape
Dim Rng As Range
Dim myshape As Object
Dim myobject As Object
Dim trgsheet As Worksheet
Set PP = GetObject(class, "PowerPoint.Application")
PP.Visible = True
Set PPpres = PP.Presentations.Open("\\C:\Users\Templates")
m = 4
'Specify the chart to copy and copy it
For Each WS In Worksheets
If WS.Name <> "EOS" Then
ThisWorkbook.Worksheets(WS.Name).Activate
LastRow = ActiveSheet.UsedRange.Rows.Count
LastCol = ActiveSheet.UsedRange.Columns.Count
'For splitting the contents across slides, tmp worksheets are created
If LastRow > 25 Then
tmpvar = 0
sTotalRowsLastSlide = LastRow - 25 * Int(LastRow / 25)
If sTotalRowsLastSlide < 4 Then
        TotalSheetsReqd = Int(LastRow / 25)
        tmpvar = 1
    Else
        TotalSheetsReqd = Int((LastRow / 25)) + 1
  End If
For k = 0 To (TotalSheetsReqd - 1)
        sFirstRowOfSheet = (25 * k) + 1
        sLastRowOfSheet = (25 * (k + 1))
         'To add tmp worksheet
          Set trgsheet = Worksheets.Add(After:=ActiveSheet)
          trgsheet.Name = WS.Name & "tmp" & k

          'To copy column header to tmp sheet
          If k > 0 Then
          Sheets(WS.Name).Activate
          Sheets(WS.Name).Range(Cells(1, 1), Cells(1, LastCol)).Copy
          Sheets(trgsheet.Name).Activate
          Sheets(trgsheet.Name).Range("A1").Select
          ActiveSheet.Paste
          End If
          'To copy contents in 25numbers across sheets created
        If k = (TotalSheetsReqd - 1) And tmpvar = 1 Then
            Sheets(WS.Name).Activate
            Sheets(WS.Name).Range(Cells(sFirstRowOfSheet, 1), Cells(LastRow, LastCol)).Copy
            Sheets(trgsheet.Name).Activate
            Sheets(trgsheet.Name).Range("A2").Select
            ActiveSheet.Paste
        ElseIf k <> (TotalSheetsReqd - 1) Or tmpvar <> 1 Then
            Sheets(WS.Name).Activate
            Sheets(WS.Name).Range(Cells(sFirstRowOfSheet, 1), Cells(sLastRowOfSheet, LastCol)).Copy
            Sheets(trgsheet.Name).Activate
            Sheets(trgsheet.Name).Range("A2").Select
            ActiveSheet.Paste
        End If

    Next k
        Application.DisplayAlerts = False
        Sheets(WS.Name).Delete
        Application.DisplayAlerts = True
   End If
 'Copy Range from Excel
  Set Rng = ThisWorkbook.ActiveSheet.Range("A1:I" & LastRow)


'Copy Excel Range
 Rng.Copy

 For k = m To 45
 PP.ActiveWindow.View.GotoSlide (k)
 'Paste to PowerPoint and position
 Set PPslide = PPpres.Slides(k)
 PPslide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
 Set myshape = PPslide.Shapes(PPslide.Shapes.Count)

 'Set position:
  myshape.Left = 48
  myshape.Top = 152

'Add the title to the slide

 SlideTitle = "Out of Support, " & WS.Name & " "
 Set PpTextbox = PPslide.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 
  20, PPpres.PageSetup.SlideWidth, 60)
 PPslide.Shapes(1).TextFrame.TextRange = SlideTitle




'Set PPslide = PPpres.Slides.Add(slidecount + 1, ppLayoutTitle)
 'Make PowerPoint Visible and Active
 PP.Visible = True
 PP.Activate


'Clear The Clipboard
 Application.CutCopyMode = True
 m = m + 1

 Exit For
 Next k



 End If

 Next WS


 End Sub
非常感谢您的帮助


提前谢谢你

工作表(WS.Name)
-为什么不仅仅是WS?!感谢jivko的回复。。我尝试在代码中使用相同的方法来拆分工作表中的内容,现在,我在以下代码行中遇到类型不匹配错误::'ElseIf k(TotalSheetsReqd-1)或tmpvar 1 Then Sheets(WS)。激活工作表(WS)。范围(单元格(sfirstrowSheet,1),单元格(sLastRowOfSheet,LastCol)).Copy“将手表添加到正在比较的变量中以查看值,您将发现类型不匹配的原因。
    **Code for splitting the contents in the worksheets**     


 If LastRow > 25 Then
  tmpvar = 0
  sTotalRowsLastSlide = LastRow - 25 * Int(LastRow / 25)


    If sTotalRowsLastSlide < 4 Then
        TotalSheetsReqd = Int(LastRow / 25)
        tmpvar = 1
    Else
        TotalSheetsReqd = Int((LastRow / 25)) + 1
    End If



    For k = 0 To (TotalSheetsReqd - 1)
        sFirstRowOfSheet = (25 * k) + 1
        sLastRowOfSheet = (25 * (k + 1))
         'To add tmp worksheet
          Set trgsheet = Worksheets.Add(After:=ActiveSheet)
          trgsheet.Name = WS.Name & "tmp" & k

          'To copy column header to tmp sheet
          If k > 0 Then
          Sheets(WS.Name).Activate
          Sheets(WS.Name).Range(Cells(1, 1), Cells(1, LastCol)).Copy
          Sheets(trgsheet.Name).Activate
          Sheets(trgsheet.Name).Range("A1").Select
          ActiveSheet.Paste
          End If
          'To copy contents in 25numbers across sheets created
        If k = (TotalSheetsReqd - 1) And tmpvar = 1 Then
            Sheets(WS.Name).Activate
            Sheets(WS.Name).Range(Cells(sFirstRowOfSheet, 1), Cells(LastRow, LastCol)).Copy
            Sheets(trgsheet.Name).Activate
            Sheets(trgsheet.Name).Range("A2").Select
            ActiveSheet.Paste
        ElseIf k <> (TotalSheetsReqd - 1) Or tmpvar <> 1 Then
            Sheets(WS.Name).Activate
            Sheets(WS.Name).Range(Cells(sFirstRowOfSheet, 1), Cells(sLastRowOfSheet, LastCol)).Copy
            Sheets(trgsheet.Name).Activate
            Sheets(trgsheet.Name).Range("A2").Select
            ActiveSheet.Paste
        End If

    Next k
        Application.DisplayAlerts = False
        Sheets(WS.Name).Delete
        Application.DisplayAlerts = True
   End If
Object defined or application defined  Run time error-1004