我有可以從 excel 提取到 PowerPoint 的代碼，但有時會顯示自動化錯誤
我嘗試使用 return 但它不起作用
你能幫我解決這個問題嗎？
到目前為止，這是我的代碼：''' Sub presntation()
Dim pptapp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
'Declare Excel Variables
Dim ExcRng As Range
Dim RngArray As Variant
Dim RngArray1 As Variant
' On Error Resume Next
' x = x - 1
' e = e - 1
' h = h - 1
Dim oPPTApp As PowerPoint.Application
Dim oPPTFile As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide
'intger ma jjsjks kskjsdkjsd
Dim Rng As Range
Dim h As Integer
Dim v As Integer
“intger1111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111111
Dim m As Integer
Dim s As Integer
p = 0
On Error GoTo errhandler
'errhandler:
'Resume Next
Dim g As Integer
Dim e As Integer
Dim p As Integer
'Do
'DoEvents
'Loop Until ie.readstate = readystate_complete
'Tate Complete
'Get the PowerPoint Application, I am assuming it's already open.
Set pptapp = New PowerPoint.Application
pptapp.Visible = True
Set oPPTApp = GetObject(, "PowerPoint.Application")
'Set a reference to the range you want to copy, and then copy it.
'Set Rng = Worksheets("Sheet1").Range("B3:N9")
' Rng.Copy
'Set a reference to the active presentation.
g = 0
m = 0
Dim o As Integer
o = 0
h = 1
e = 0
x = 0
errhandler:
If p = 1 Then
oPPTFile.Slides(s).Delete
If x = 0 Then
GoTo Go
'
Else
If x = Even.Value = True Then
s = s - 1
'x = x - 1
e = e - 1
GoTo Go
Else
s = s - 1
x = x - 2
e = e - 2
GoTo Go
End If
End If
Else
End If
'Populate our array
' If x = 0 Then
' Sheets("WBB2").Select
' Else
' If x = 1 Then
' Sheets("WBB3").Select
' Else
' End If
'End If
'Create a new instance of PowerPoint
s = 1
e = 0
' Set pptapp = New PowerPoint.Application
' pptapp.Visible = True
'Create a new Presentation
Set PPTPres = pptapp.Presentations.Add
'RngArray = Array(Worksheets("Backup data1").Range("E9:O38"))
RngArray = Array(Worksheets("Backup data1").Range("E9:O38"), Worksheets("Backup
data1").Range("E6:O8"), Worksheets("Backup data1").Range("E50:O79"), Worksheets("Backup
data1").Range("E47:O49"), Worksheets("Backup data1").Range("E87:O116"), Worksheets("Backup
data1").Range("E84:O86"), Worksheets("Backup data1").Range("E127:O156"), Worksheets("Backup
data1").Range("E123:O125"), Worksheets("Backup data1").Range("E165:O195"), Worksheets("Backup
data1").Range("E163:O165"), Worksheets("Backup data1").Range("E203:O232"), Worksheets("Backup
data1").Range("E200:O202"), Worksheets("Backup data1").Range("E241:O270"), Worksheets("Backup
data1").Range("E237:O239"), Worksheets("Backup data1").Range("C307:L314"), Worksheets("Backup
data1").Range("D301:K303"), Worksheets("Backup data1").Range("C335:L340"), Worksheets("Backup
data1").Range("D329:K331"), Worksheets("Backup data1").Range("C365:L372"), Worksheets("Backup
data1").Range("D359:K361"), _
Worksheets("Backup data1").Range("C393:L396"), Worksheets("Backup data1").Range("D387:K389"),
Worksheets("Backup data1").Range("C421:L428"), Worksheets("Backup data1").Range("D415:K417"),
Worksheets("Backup data1").Range("C449:L455"), Worksheets("Backup data1").Range("D443:K445"),
Worksheets("Backup data1").Range("C477:L479"), Worksheets("Backup data1").Range("D471:K473"),
Worksheets("Backup data1").Range("C505:L510"), Worksheets("Backup data1").Range("D499:K501"),
Worksheets("Backup data1").Range("A531:F544"), Worksheets("Backup data1").Range("B527:K529"))
'Loop through the range array, create a slide for each range, and copy that range on to the
slide.
For x = LBound(RngArray) To UBound(RngArray)
Go:
'Set a reference to the range
Set ExcRng = RngArray(x)
'Copy Range
ExcRng.Copy
'Enable this line of code if you recieve error about the range not being in the clipboard
- This will fix that error by pausing the program for ONE Second.
Set oPPTFile = oPPTApp.ActivePresentation
If h = 1 Then
If m = 2 Then
Set oPPTSlide = Nothing
Set PPTSlide = Nothing
x = x - (1 g)
Set PPTSlide = PPTPres.Slides.Add(x 1, ppLayoutBlank)
' Application.Wait Now #12:00:01 AM#
m = 1
x = x (1 g)
s = s 1
g = g 1
Else
m = m 1
Set PPTSlide = PPTPres.Slides.Add(x 1, ppLayoutBlank)
End If
'Set PPTSlide = PPTPres.Slides.Add(x 1, ppLayoutBlank)
'x = x 1
'Set a reference to the slide you want to paste it on.
Set oPPTSlide = oPPTFile.Slides(s)
Else
m = m 1
End If
Application.Wait Now TimeValue("00:00:02")
p = 1
'On Error GoTo errhandler
'errhandler:
'Resume Next
'WARNING THIS METHOD IS VERY VOLATILE, PAUSE THE APPLICATION TO SELECT THE SLIDE
For i = 1 To 5000: DoEvents: Next
oPPTSlide.Select
'WARNING THIS METHOD IS VERY VOLATILE, PAUSE THE APPLICATION TO PASTE THE OBJECT
For i = 1 To 10000: DoEvents: Next
oPPTApp.CommandBars.ExecuteMso "PasteSourceFormatting"
oPPTApp.CommandBars.ReleaseFocus
For i = 1 To 10000: DoEvents: Next
'
If e < 14 Then
If h = 2 Then
With oPPTApp.ActiveWindow.Selection.ShapeRange
.Top = 20
.Left = 25
.Width = 910
End With
Set oPPTSlide = Nothing
Set PPTSlide = Nothing
h = 0
'Application.Wait Now #12:00:01 AM#
Else
With oPPTApp.ActiveWindow.Selection.ShapeRange
.Top = 80
.Left = 50
.Height = 450
.Width = 870
' Application.Wait Now #12:00:01 AM#
End With
End If
Else
If h = 2 Then
With oPPTApp.ActiveWindow.Selection.ShapeRange
.Top = 20
.Left = 25
.Width = 910
Set oPPTSlide = Nothing
Set PPTSlide = Nothing
End With
h = 0
Else
With oPPTApp.ActiveWindow.Selection.ShapeRange
.Top = 80
.Left = 50
.Height = 300
' .Height = 200
.Width = 870
End With
End If
End If
o = o 1
e = e 1
'Create a new Slide
'Set PPTSlide = PPTPres.Slides.Add(x 1, ppLayoutBlank)
'Paste the range in the slide as a linked OLEObject
'PPTApp.CommandBars.ExecuteMso
'PPTSlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject
' pptApplication.CommandBars.ExecuteMso ("PasteSourceFormatting")
h = h 1
Next x
End Sub
uj5u.com熱心網友回復：
您正在使用“設定 oPPTFile = oPPTApp.ActivePresentation”
根據您在宏運行期間執行的操作，PowerPoint 可能會失去焦點，然后“ActivePresentation”為空。在使用“Set PPTPres = pptapp.Presentations.Add”之前的一些行
作為快速解決方法，請嘗試使用“Set oPPTFile = PPTPres”而不是“Set oPPTFile = oPPTApp.ActivePresentation”，對于未來的專案：如果您已將物件分配給變數，請使用此變數而不是 ActivePresentation。
uj5u.com熱心網友回復：
可能是您等待粘貼完成的時間不夠長。嘗試這里描述的方法
Option Explicit
Sub presntation()
' Power point variables
Dim oPPTApp As PowerPoint.Application
Dim oPPTPres As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide
' Excel Variables
Dim xl As Excel.Application
Dim wb As Workbook
Dim i As Long, RngArray As Variant, p As Integer, t0 As Single
Dim n As Integer
t0 = Timer
RngArray = Array("E9:O38", "E6:O8", "E50:O79", "E47:O49", _
"E87:O116", "E84:O86", "E127:O156", "E123:O125", _
"E165:O195", "E163:O165", "E203:O232", "E200:O202", _
"E241:O270", "E237:O239", "C307:L314", "D301:K303", _
"C335:L340", "D329:K331", "C365:L372", "D359:K361", _
"C393:L396", "D387:K389", "C421:L428", "D415:K417", _
"C449:L455", "D443:K445", "C477:L479", "D471:K473", _
"C505:L510", "D499:K501", "A531:F544", "B527:K529")
' Get the PowerPoint Application, I am assuming it's already open.
'Set oPPTApp = GetObject(, "PowerPoint.Application")
' Create new presentation
Set oPPTApp = New PowerPoint.Application
oPPTApp.Visible = msoTrue
Set oPPTPres = oPPTApp.Presentations.Add(msoTrue)
' create slides
Set wb = ThisWorkbook
Set xl = wb.Parent
For i = LBound(RngArray) To UBound(RngArray) Step 2
' create slide
If i Mod 2 = 0 Then
p = p 1
oPPTPres.Slides.Add p, ppLayoutBlank
End If
xl.StatusBar = "Creating slide " & p
Set oPPTSlide = oPPTPres.Slides(p)
oPPTSlide.Select
'Copy Top Range
wb.Worksheets("Backup data1").Range(RngArray(i 1)).Copy
n = oPPTSlide.Shapes.Count
oPPTApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"
' wait for shape to be created
Do
DoEvents
Loop Until oPPTSlide.Shapes.Count > n
With oPPTSlide.Shapes(oPPTSlide.Shapes.Count)
.Top = 20
.Left = 25
.Width = 910
End With
xl.CutCopyMode = False
'Copy Bottom Range
wb.Worksheets("Backup data1").Range(RngArray(i)).Copy
n = oPPTSlide.Shapes.Count
oPPTApp.CommandBars.ExecuteMso "PasteExcelTableSourceFormatting"
' wait for shape to be created
Do
DoEvents
Loop Until oPPTSlide.Shapes.Count > n
With oPPTSlide.Shapes(oPPTSlide.Shapes.Count)
.Top = 80
.Left = 50
.Width = 870
If i < 14 Then
.Height = 450
Else
.Height = 300
End If
End With
xl.CutCopyMode = False
Next i
AppActivate xl.Caption
xl.StatusBar = "Done"
MsgBox p & " slides created", vbSystemModal, Format(Timer - t0, "0.0 secs")
End Sub
轉載請註明出處，本文鏈接：https://www.uj5u.com/qita/325988.html
上一篇：VBA如何根據現有串列檢查重復值并僅從新串列中添加唯一實體
下一篇：MQTT 基本知識簡介