Kopieren Arbeitsblatt Makro nicht mehr etwas zu tun, wenn die Arbeitsmappe 50 Arbeitsblatt Treffer

Question

Ich habe eine Arbeitsmappe, die eine Reihe von Deckblättern haben und dann eine Reihe von Blättern auf der Rückseite, die ein paar Diagramme enthalten ist. Die Diagrammseiten werden durch copy-Einfügen ein Blatt erstellt ( „Masterformat“) immer und immer wieder, ein paar Schlüsselwerte jedes Mal zu ändern.

Das Makro ursprünglich auf den Geist aufgibt ziemlich schnell mit einem Copy Method of Worksheet Class failed Fehler verwendet. Schließlich fand ich, wie es zu beheben, von http://support.microsoft.com/kb/210684.

Das Problem ist, ich habe mit meiner aktualisierte Version endlose Probleme hat; meist, dass es weiterhin glücklich ausgeführt wird, wird aber nicht wirklich etwas nach einer Weile kopieren. Ein Teil der Grund, warum es glücklich ist, dass die aktualisierte Logik ein paar Set x = y, if x is nothing thens umfasst, die (soweit ich weiß) nur unterdrückt mit Fehlern arbeiten, so dass das, was ich getan habe. Aber auf der anderen Seite, stoppt sie das Kopieren Blätter nach dort 50 Blätter sind, und gibt keine Erklärung (obwohl dies die mislocation des on error goto 0 sein kann).

Wer weiß, was sollte ich es tatsächlich kopieren Sie alle Blätter machen werden Befestigung, nicht nur langweilig und stoppen?

Der Code lautet wie folgt:

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

Es ist aus einer Meta-Arbeitsmappe ausführen, die der Vorschlag des KB-Artikels war ich oben verlinkt. Interessanterweise trotz der Open workbook, scheint es nicht wirklich zu funktionieren, wenn die Haupt-Arbeitsmappe nicht geöffnet ist.

Answer 1

Der Fehler wahrscheinlich durch diese Linie verursacht wird:

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

Der Sheets(j) der Code-Modul befindet sich in zu je nachdem, was Arbeitsmappe beziehen, die nicht der richtige Arbeitsmappe sein kann.

Die folgenden Werke für mich:

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

habe ich die Freiheit, die die Nähe des Ersetzens / wieder öffnet mit einem einfachen Save, da dies das gleiche Ergebnis erzielen sollte?

Answer 2

Versuchen Sie,

        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"

in

     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

Ich denke, wenn ws ist nichts dann steckte sie in nächsten 3 Zeilen.

Answer 3

Basierend auf Lunatik Antwort, ich änderte oBook.Sheets("MasterFormat").Copy After:=Sheets(j) zu oBook.Sheets("MasterFormat").Copy After:=oBook.Sheets(j), das schien das Problem zu beheben.