Question

有人可以给我一些帮助，弄清楚为什么我的程序每次尝试运行时都会崩溃吗？崩溃似乎发生在我拥有的任何复制/粘贴行中，所以：

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

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)

复制期间Cofusing程序崩溃

1 个答案: