创建循环以将多个 Sheet 范围作为图片粘贴到 Power Point
Creating a Loop to Paste Multiple Sheet Ranges to Power Point as Pictures
我一直在尝试修改下面的代码,但在 ReDim Preserve arr(k - 1)
.
行收到错误 Script out of range
代码取 Status of Col"E"
如果是 = Include 那么其对应的工作表范围将作为图片粘贴到 Power Point。
但这不起作用,我们将不胜感激您的帮助。
Sub SelectSheets_Ranges()
Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
ReDim arr(lastR - 1)
For i = 5 To lastR
If sh.Range("E" & i).Value = "Include" Then
arr(k) = sh.Range("C" & i).Value & "|" & sh.Range("D" & i).Value: k = k + 1
End If
Next i
ReDim Preserve arr(k - 1)
For i = 0 To UBound(arr)
arrSplit = Split(arr(i), "|")
Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
''''
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Err.Clear
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
Application.ScreenUpdating = False
Set myPresentation = PowerPointApp.Presentations.Add
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = 66
myShape.Top = 152
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.CutCopyMode = False
'''''''''
Next
End Sub
请使用下一个代码:
Sub SelectSheets_Ranges()
Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
Dim PowerPointApp As Object, myPresentation As Object, mySlide As Object, myShape As Object
On Error Resume Next
Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
err.Clear
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")
If err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
Set myPresentation = PowerPointApp.Presentations.Add
Set sh = ActiveSheet
lastR = sh.Range("C" & sh.rows.count).End(xlUp).row
ReDim arr(lastR - 1)
For i = 5 To lastR
If sh.Range("E" & i).value = "Include" Then
arr(k) = sh.Range("C" & i).value & "|" & sh.Range("D" & i).value: k = k + 1
End If
Next i
ReDim Preserve arr(k - 1)
For i = 0 To UBound(arr)
arrSplit = Split(arr(i), "|")
Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
Application.ScreenUpdating = False
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.count)
myShape.left = 66
myShape.top = 152
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.CutCopyMode = False
Next
End Sub
我一直在尝试修改下面的代码,但在 ReDim Preserve arr(k - 1)
.
Script out of range
代码取 Status of Col"E"
如果是 = Include 那么其对应的工作表范围将作为图片粘贴到 Power Point。
但这不起作用,我们将不胜感激您的帮助。
Sub SelectSheets_Ranges()
Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.Rows.Count).End(xlUp).Row
ReDim arr(lastR - 1)
For i = 5 To lastR
If sh.Range("E" & i).Value = "Include" Then
arr(k) = sh.Range("C" & i).Value & "|" & sh.Range("D" & i).Value: k = k + 1
End If
Next i
ReDim Preserve arr(k - 1)
For i = 0 To UBound(arr)
arrSplit = Split(arr(i), "|")
Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
''''
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
Err.Clear
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
Application.ScreenUpdating = False
Set myPresentation = PowerPointApp.Presentations.Add
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
myShape.Left = 66
myShape.Top = 152
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.CutCopyMode = False
'''''''''
Next
End Sub
请使用下一个代码:
Sub SelectSheets_Ranges()
Dim sh As Worksheet, lastR As Long, rng As Range, arr, arrSplit, i As Long, k As Long
Dim PowerPointApp As Object, myPresentation As Object, mySlide As Object, myShape As Object
On Error Resume Next
Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
err.Clear
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")
If err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
Set myPresentation = PowerPointApp.Presentations.Add
Set sh = ActiveSheet
lastR = sh.Range("C" & sh.rows.count).End(xlUp).row
ReDim arr(lastR - 1)
For i = 5 To lastR
If sh.Range("E" & i).value = "Include" Then
arr(k) = sh.Range("C" & i).value & "|" & sh.Range("D" & i).value: k = k + 1
End If
Next i
ReDim Preserve arr(k - 1)
For i = 0 To UBound(arr)
arrSplit = Split(arr(i), "|")
Set rng = Worksheets(arrSplit(0)).Range(arrSplit(1))
Application.ScreenUpdating = False
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
rng.Copy
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.count)
myShape.left = 66
myShape.top = 152
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.CutCopyMode = False
Next
End Sub