0
有人可以幫我弄清楚爲什麼我的程序每次嘗試運行時都會崩潰嗎？崩潰似乎在任何我必須複製/粘貼線的情況發生，所以：在複製過程中混淆程序崩潰
ShRef.Range(ShRef.Cells(ShRef.Rows.Count, pCol).End(xlUp), ShRef.Cells(1, pCol)).Copy Destination:=ShWork.Columns(outCol)ShRef.Range(ShRef.Cells(ShRef.Rows.Count, 1).End(xlUp), ShRef.Cells(oneOrTwo, 1)).Copy Destination:=ShWork.Cells(rowCounter, 1)ShRef.Range(ShRef.Cells(ShRef.Rows.Count, pCol).End(xlUp), ShRef.Cells(oneOrTwo, pCol)).Copy Destination:=ShWork.Cells(rowCounter, 2)Set myShape = pptSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse)
我真的不知道爲什麼會發生這種情況，因爲之前的工作原理相同。任何幫助表示讚賞，這裏是我的代碼的其餘部分：
Public Sub averageScoreRelay()
' 1. Run from PPT and open an Excel file
' 2. Start at slide 1 and find a box that contains the words "iq_", if it has those words then it will have numbers after it like so "iq_43" or "iq_43, iq_56,iq_72".
' 3. find those words and numbers in the opened Excel file after splitting and re-formating string.
' 3. Copy column into a new sheets and repeat for all "iq_'s" until sheets 2 has a table.
' 4. Copy table from xl Paste Table into ppt
' 5. Do this for every slide
'Timer start
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'Create variables
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim ShRef As Excel.Worksheet
Dim ShWork As Excel.Worksheet
Dim pptPres As Object
Dim colNumb As Long
Dim rowNumb As Long
' Create new excel instance and open relevant workbook
Set xlApp = New Excel.Application
'xlApp.Visible = True 'Make Excel visible
Set xlWB = xlApp.Workbooks.Open("c:/filepath", True, False, , , , True, Notify:=False) 'Open relevant workbook
If xlWB Is Nothing Then ' may not need this if statement. check later.
MsgBox ("Error retrieving Average Score Report, Check file path")
Exit Sub
End If
xlApp.DisplayAlerts = False
'Find # of iq's in workbook
Set ShRef = xlWB.Worksheets("Sheet1")
colNumb = ShRef.Cells(1, ShRef.Columns.Count).End(xlToLeft).Column
rowNumb = ShRef.Cells(ShRef.Rows.Count, 1).End(xlUp).Row
Dim IQRef() As String
Dim iCol As Long
ReDim IQRef(colNumb)
' capture IQ refs locally
For iCol = 2 To colNumb
IQRef(iCol) = ShRef.Cells(1, iCol).Value
Next iCol
'Create a new blank Sheet in excel, should be "Sheet2"
xlWB.Worksheets.Add After:=xlWB.ActiveSheet
Set ShWork = xlWB.Worksheets("Sheet2")
'Make pptPres the ppt active
Set pptPres = PowerPoint.ActivePresentation
'Create variables for the slide loop
Dim pptSlide As Slide
Dim Shpe As Shape
Dim pptText As String
Dim iq_Array As Variant
Dim arrayLoop As Long
Dim myShape As Object
Dim outCol As Long
Dim i As Long
Dim hasIQs As Boolean
Dim checkStr As String
Dim pCol As Long
Dim checkOne
Dim iQRefArray As Variant
Dim iQRefString As String
Dim checkRefStr As String
Dim rowCounter As Long
Dim oneOrTwo As Long
'Loop through each pptSlide and check for IQ text box, grab avgScore values and create pptTable
For Each pptSlide In pptPres.Slides
i = 0
pptSlide.Select
'searches through shapes in the slide
For Each Shpe In pptSlide.Shapes
If Not Shpe.HasTextFrame Then GoTo nextShpe 'boom, one less nested If statement
If Not Shpe.TextFrame.HasText Then GoTo nextShpe ' boom, another nested If statement bites the dust
outCol = 1
'Set pptText as the Text in the box, then make it lowercase and trim Spaces and Enters
pptText = Shpe.TextFrame.TextRange
pptText = LCase(Replace(pptText, " ", vbNullString))
pptText = Replace(Replace(Replace(pptText, vbCrLf, vbNullString), vbCr, vbNullString), vbLf, vbNullString)
'Identify if within text there is "iq_"
If InStr(1, pptText, "iq_") <= 0 Then GoTo nextShpe
'set iq_Array as an array of the split iq's
iq_Array = Split(pptText, ",")
checkOne = iq_Array(0)
hasIQs = Left(checkOne, 3) = "iq_"
If hasIQs Then
' paste inital column into temporary worksheet
ShRef.Columns(1).Copy Destination:=ShWork.Columns(1)
End If
' loop for each iq_ in the array
For arrayLoop = LBound(iq_Array) To UBound(iq_Array)
' Take copy of potential ref and adjust to standard if required
checkStr = iq_Array(arrayLoop)
If hasIQs And Left(checkStr, 3) <> "iq_" Then checkStr = "iq_" & checkStr
rowCounter = 2
' Look for existence of corresponding column in local copy array
For iCol = 2 To colNumb
pCol = 0
'format the numbers in the excel file to fit code needs. The full form for iq_'s in the excel database is: "iq_66_01__A_"
iQRefString = Left(IQRef(iCol), Len(IQRef(iCol)) - 1)
iQRefArray = Replace(iQRefString, "__", "_")
iQRefArray = Split(iQRefArray, "_")
checkRefStr = "iq_" & iQRefArray(1)
If checkStr = checkRefStr Then
pCol = iCol
End If
If pCol > 0 Then
If iQRefArray(3) = "A" Then
' Paste the corresponding column into the forming table
outCol = outCol + 1
ShRef.Range(ShRef.Cells(ShRef.Rows.Count, pCol).End(xlUp), ShRef.Cells(1, pCol)).Copy Destination:=ShWork.Columns(outCol)
ElseIf iQRefArray(3) = "AT" Then
outCol = outCol + 1
If outCol = 3 Then
rowCounter = rowCounter + rowNumb + 1
oneOrTwo = 2
ElseIf outCol <> 2 Then
rowCounter = rowCounter + rowNumb
oneOrTwo = 2
Else
rowCounter = 1
oneOrTwo = 1
End If
ShRef.Range(ShRef.Cells(ShRef.Rows.Count, 1).End(xlUp), ShRef.Cells(oneOrTwo, 1)).Copy Destination:=ShWork.Cells(rowCounter, 1)
ShRef.Range(ShRef.Cells(ShRef.Rows.Count, pCol).End(xlUp), ShRef.Cells(oneOrTwo, pCol)).Copy Destination:=ShWork.Cells(rowCounter, 2)
End If
End If
Next iCol
If outCol > 1 Then 'data was added
' Copy table
ShWork.UsedRange.Copy ' all the data added to ShWork gets copied
tryAgain:
ActiveWindow.ViewType = ppViewNormal
ActiveWindow.Panes(2).Activate
Set myShape = pptSlide.Shapes.PasteSpecial(DataType:=ppPasteHTML, Link:=msoFalse)
On Error GoTo tryAgain
On Error GoTo clrSht
'Set position:
myShape.Left = -200
myShape.Top = 150 + i
i = i + 150
clrSht:
' Clear data from temporary sheet
ShWork.UsedRange.Clear
rowCounter = 1
outCol = 1
End If
Next arrayLoop
nextShpe:
Next Shpe
Next pptSlide
ShWork.Delete
xlWB.Close
xlApp.Quit
xlApp.DisplayAlerts = True
'End Timer
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
End Sub
有什麼具體的錯誤消息？你能做一個能重現問題的[mcve]嗎？這是相當多的代碼... –
它崩潰的確切線是什麼？你可以設置一個斷點並找出它。你也可以嘗試對該行進行註釋，看它是否會給出任何其他錯誤。 –
@ Mat'sMug沒有具體的信息，我只是拿到了轉輪，程序沒有迴應 – Pinlop