Question

如果有人可以提供以下帮助，我将不胜感激。以下代码从MS Excel复制范围并将其粘贴到MS PowerPoint中。此外，还有一个循环遍历工作簿的所有工作表并应用相同的复制和粘贴公式。但是，我正在努力如何关闭＆＃34;它到达最后一个工作表时的循环。在代码的最后，我得到一个运行时错误＆＃39; 91＆＃39;：对象变量或With块变量未设置，当我选择Debug时，它突出显示sh(ActiveSheet.Index + 1).Select。

Sub CreateDeck()

Dim WSheet_Count As Integer
Dim I As Integer
Dim Rng As Excel.Range
Dim PPTApp As PowerPoint.Application
Dim myPPT As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim sh As Worksheet

'Set WSheet_Count equal to the number of worksheet in the active workbook

WSheet_Count = ActiveWorkbook.Worksheets.Count

'Around the world: The Loop

For I = 1 To WSheet_Count

'Copy Range from excel

Set Rng = ThisWorkbook.ActiveSheet.Range("A1:A2")

'Creat Instance for PowerPoint

On Error Resume Next

'Check if PowerPoint is open

Set PPTApp = GetObject(class:="PowerPoint.Application")

'Clear the error between errors

Err.Clear

'Open PowerPoint if it is not open

If PPTApp Is Nothing Then Set PPTApp = CreateObject(class:="PowerPoint.Application")

'Handle if PowerPoint cannot be found

If Err.Number = 429 Then
    MsgBox ("PowerPoint couldn't be found, aborting")
Exit Sub

End If

On Error GoTo 0

'Make PowerPoint Visible and Active


PPTApp.Visible = True
PPTApp.Activate

'Create New PowerPoint

If PPTApp Is Nothing Then
    Set PPTApp = New PowerPoint.Application
End If

'Make New Presentation

If PPTApp.Presentations.Count = 0 Then
    PPTApp.Presentations.Add
End If

'Add Slide to the presentation

PPTApp.ActivePresentation.Slides.Add PPTApp.ActivePresentation.Slides.Count + 1, ppLayoutBlank

PPTApp.ActiveWindow.View.GotoSlide PPTApp.ActivePresentation.Slides.Count

Set mySlide = PPTApp.ActivePresentation.Slides(PPTApp.ActivePresentation.Slides.Count)

'Copy Excel Range

Rng.Copy

'Paste to PowerPoint and Position

mySlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile

Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)

'Set position

myShapeRange.Left = 0
myShapeRange.Top = 0
myShapeRange.Height = 450

'Clear the Clipboard

Application.CutCopyMode = False

'Next Worksheet tab

sh(ActiveSheet.Index + 1).Select

Next I

End Sub

Answer 1

你的脚本在循环Worksheets方面做得非常好，但实际上有一个内置的Collection专为这种情况而设计。

ThisWorkbook.Worksheets包含Worksheets中的所有ThisWorkbook - 您可以像这样遍历它：

Option Explicit
Public Sub LoopThroughAllWorksheets()
    Dim wks As Worksheet
    For Each wks In ThisWorkbook.Worksheets
        MsgBox "On sheet: " & wks.Index
    Next wks
End Sub

这意味着您可以调整For...Next循环，以便像这样工作：

For Each sh in ThisWorkbook.Worksheets
    'do stuff, like:
    'Set Rng = sh.Range("A1:A2")
    'etc.
Next sh

利用Worksheets集合还可以帮助您避免使用.Select和ActiveSheet，这可能会给您的用户带来很多痛苦：

How To Avoid Using Select in Excel VBA Macros

Answer 2

您将变量sh声明为Worksheet，但从不为其指定值。例外情况是当它指出＆＃34; 对象变量没有设置＆＃34;时会尝试表明这一点。

在行中：

sh(ActiveSheet.Index + 1).Select

您正在尝试调用尚未分配值的sh工作表。您似乎在尝试在此处进行不正确的分配。你可以使用像ThisWorkbook.Worksheets(ActiveSheet.Index + 1).Select这样的东西来实现这个功能，但你的循环也必须进行修改才能实现。

如果您只是尝试遍历工作簿中的所有工作表，则可以简单地使用内置集合，而不必担心如何处理索引。

Option Explicit
Dim ws As Worksheet
Sub MessageAllNames()
    For Each ws In ThisWorkbook.Worksheets
       ' Everything that should be contained within your loop, for example...
       MsgBox ws.Name
    Next ws
End Sub

结束遍历Excel

2 个答案: