La macro de copia de la hoja de trabajo deja de hacer nada cuando el libro llega a 50 hojas de trabajo

Question

Tengo un libro de trabajo que tiene una serie de hojas de portada y luego un montón de hojas en la parte posterior que contienen algunos gráficos. Las páginas del gráfico se crean copiando y pegando una hoja (" MasterFormat ") una y otra vez, cambiando unos pocos valores clave cada vez.

La macro originalmente utilizada para comunicarse con bastante rapidez con un error de Copy Method of Worksheet Class . Finalmente encontré cómo solucionarlo, en http://support.microsoft.com/kb/210684.

El problema es que he tenido un sinfín de problemas con mi versión actualizada; sobre todo que sigue funcionando felizmente, pero en realidad no copia nada después de un tiempo. Parte de la razón por la que está contento es que la lógica actualizada incluye algunos Set x = y, si x no es nada entonces s, que (por lo que sé) solo funcionará con los errores suprimidos, así que eso es lo que Hice. Pero, por otro lado, deja de copiar las hojas después de que hay 50 hojas, y no da ninguna explicación (aunque esto puede ser una mala localización del en caso de error 0 ).

¿Alguien sabe lo que debería arreglar para que en realidad copie todas las hojas, no solo que se aburra y se detenga?

El código es el siguiente:

Sub GenerateSheets()
    Application.ScreenUpdating = False

    Dim oBook As Workbook

    On Error Resume Next
    Set oBook = Workbooks("SSReport.xls")

    If oBook Is Nothing Then
        Set oBook = Application.Workbooks.Open("SSReport.xls")
    End If
    On Error GoTo 0

    Dim i, j As Integer
    Dim SheetName As String
    Dim ws As Worksheet
    Const PairingCount = 63

    Dim Pairings(1 To PairingCount, 1 To 2) As String
    For i = 1 To PairingCount
        Pairings(i, 1) = oBook.Sheets("SSPairings").Rows(i + 1).Cells(1)
        Pairings(i, 2) = oBook.Sheets("SSPairings").Rows(i + 1).Cells(2)
    Next i

    For i = 1 To PairingCount

         If i Mod 5 = 0 Then
            oBook.Close SaveChanges:=True
            Set oBook = Nothing
            Set oBook = Application.Workbooks.Open("SSReport.xls")
         End If

        Application.ScreenUpdating = False
        j = oBook.Worksheets.Count
        SheetName = "P" & Pairings(i, 1) & Pairings(i, 2)
        On Error Resume Next
        Set ws = oBook.Sheets(SheetName)
        If ws Is Nothing Then
            On Error GoTo 0
            oBook.Sheets("MasterFormat").Copy After:=Sheets(j)
            oBook.Sheets("MasterFormat (2)").Name = SheetName
        End If
        oBook.Sheets(SheetName).Cells(1, 2) = Pairings(i, 1)
        oBook.Sheets(SheetName).Cells(1, 5) = Pairings(i, 2)
        oBook.Sheets(SheetName).Cells(1, 8) = "P"
    Next i

    Application.ScreenUpdating = True
End Sub

Se ha ejecutado desde un meta libro de trabajo, que fue la sugerencia del artículo de KB al que he vinculado anteriormente. Curiosamente, a pesar del Abrir libro de trabajo , no parece funcionar realmente si el libro de trabajo principal no está abierto.

Answer 1

El error probablemente se deba a esta línea:

oBook.Sheets("MasterFormat").Copy After:=Sheets(j)

El Sheets (j) se referirá al libro de trabajo en el que reside el módulo de código, que puede no ser el libro previsto.

Lo siguiente funciona para mí:

Sub GenerateSheets()
Dim oBook As Workbook
Dim i As Long
Dim j As Long
Dim SheetName As String
Dim ws As Worksheet
Const PairingCount = 63
Dim Pairings(1 To PairingCount, 1 To 2) As String

On Error Resume Next
Set oBook = Workbooks("SSReport.xls")
On Error GoTo 0
If oBook Is Nothing Then
    Set oBook = Application.Workbooks.Open("SSReport.xls")
End If

With oBook
    For i = 1 To PairingCount
        Pairings(i, 1) = .Sheets("SSPairings").Rows(i + 1).Cells(1)
        Pairings(i, 2) = .Sheets("SSPairings").Rows(i + 1).Cells(2)
    Next i

    For i = 1 To PairingCount
        If i Mod 5 = 0 Then
            '//Save in case of corruption/error?'
            .Save
        End If

        j = .Worksheets.Count

        SheetName = "P" & Pairings(i, 1) & Pairings(i, 2)

        On Error Resume Next
        Set ws = .Sheets(SheetName)
        On Error GoTo 0
        If ws Is Nothing Then
            .Sheets("MasterFormat").Copy After:=.Sheets(j)
            .Sheets("MasterFormat (2)").Name = SheetName
        End If

        .Sheets(SheetName).Cells(1, 2) = Pairings(i, 1)
        .Sheets(SheetName).Cells(1, 5) = Pairings(i, 2)
        .Sheets(SheetName).Cells(1, 8) = "P"
    Next i
End With
End Sub

Me tomé la libertad de reemplazar el cierre / reapertura con un simple Guardar , ya que esto debería lograr el mismo resultado.

Answer 2

Intenta cambiar

        If ws Is Nothing Then
            On Error GoTo 0
            oBook.Sheets("MasterFormat").Copy After:=Sheets(j)
            oBook.Sheets("MasterFormat (2)").Name = SheetName
        End If
        oBook.Sheets(SheetName).Cells(1, 2) = Pairings(i, 1)
        oBook.Sheets(SheetName).Cells(1, 5) = Pairings(i, 2)
        oBook.Sheets(SheetName).Cells(1, 8) = "P"

en

     If ws Is Nothing Then
        On Error GoTo 0
        oBook.Sheets("MasterFormat").Copy After:=Sheets(j)
        oBook.Sheets("MasterFormat (2)").Name = SheetName
    else
       oBook.Sheets(SheetName).Cells(1, 2) = Pairings(i, 1)
       oBook.Sheets(SheetName).Cells(1, 5) = Pairings(i, 2)
       oBook.Sheets(SheetName).Cells(1, 8) = "P"
    End If

Supongo que si ws no es nada, entonces se atasca en las siguientes 3 líneas.

Answer 3

Según la respuesta de Lunatik, cambié oBook.Sheets (" MasterFormat "). Copy After: = Sheets (j) a oBook.Sheets (" MasterFormat "). Copy Después de: = oBook.Sheets (j) , que pareció solucionar el problema.