在复制过程中导致程序崩溃

有人能给我一些帮助，找出为什么我的程序崩溃，每次我试图运行它？ 崩溃似乎发生在我有任何复制/粘贴行，所以：

1. ShRef.Range(ShRef.Cells(ShRef.Rows.Count, pCol).End(xlUp), ShRef.Cells(1, pCol)).Copy Destination:=ShWork.Columns(outCol)

2. ShRef.Range(ShRef.Cells(ShRef.Rows.Count, 1).End(xlUp), ShRef.Cells(oneOrTwo, 1)).Copy Destination:=ShWork.Cells(rowCounter, 1)

3. ShRef.Range(ShRef.Cells(ShRef.Rows.Count, pCol).End(xlUp), ShRef.Cells(oneOrTwo, pCol)).Copy Destination:=ShWork.Cells(rowCounter, 2)

4. 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 

Answer 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)