Cofusing Crash du programme pendant la copie

Question

Quelqu'un pourrait-il m'aider à comprendre pourquoi mon programme plante à chaque fois que j'essaie de l'exécuter? L'accident semble se produire au cours de l'une des lignes à copier/coller que j'ai, donc:

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)

Je ne sais vraiment pas pourquoi cela se produit, car les mêmes commandes fonctionnaient auparavant. Toute aide est appréciée, et voici le reste de mon code:

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

Chaque option de copier et coller plantait, mais c'est parce que ce coupable d'origine était là:

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

Notez que il imprime sur toute la colonne, donc à travers de multiples itérations, Sheet2 aurait plus de 30 millions de cellules de valeur. Ensuite, lorsque le programme est allé copier tout le contenu de Sheet2 et coller sur PowerPoint, il se bloque immédiatement.

Je l'ai fixé par writting:

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