有人可以给我一些帮助，弄清楚为什么我的程序每次尝试运行时都会崩溃吗？崩溃似乎发生在我拥有的任何复制/粘贴行中，所以：
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
答案 0 :(得分：1)
每个复制和粘贴选项都崩溃了，但那是因为这个原始罪魁祸首在那里：
ShRef.Range(ShRef.Cells(ShRef.Rows.Count, pCol).End(xlUp), ShRef.Cells(1, pCol)).Copy Destination:=ShWork.Columns(outCol)
请注意，它正在打印到整个列，因此通过多次迭代，Sheet2将拥有超过3000万个单元格的值。然后当程序从Sheet2复制所有内容并粘贴到PowerPoint上时，它会立即崩溃。
我通过写作修正了它：
ShRef.Range(ShRef.Cells(ShRef.Rows.Count, pCol).End(xlUp), ShRef.Cells(1, pCol)).Copy Destination:=ShWork.Cells(,outCol)