EXCEL-Bug
03.04.2011 16:43:24
Jörg-HH
Hallo Erich und alle anderen
nun sehe ich, daß das ja schon öfter diskutiert wurde. Danke für die Links, Erich.
Ich hatte dazu gestern noch jmd gefragt, der mir sagte, daß dies ein uralter und nie behobener Bug ist. Er hat aktuell einen Code geschrieben, der das Problem umgeht, indem man sich auf das kopieren in 30-Blatt-Häppchen in eine neue Datei beschränkt, diese 30 dann in die Orig-Datei überträgt, die neue Datei fein säuberlich abschießt und dann die nächsten 30 Blättchen in Angriff nimmt.
Schönen Rest-Sonntag!
Jörg
Sub NeuesBlatt()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim idx As Integer
Dim AnzahlBlätter As Integer
Dim NewWS As Worksheet
Dim sh As Shape
Dim NewName As String
Dim wb As Workbook
Dim arrSheets() As String
Dim nam As Name
Dim ws As Worksheet
Set NewWS = ThisWorkbook.Worksheets("Master")
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.Calculation = xlManual
'Funktion: Alle 30 Blätter ne neue Arbeitsmappe aufmachen,
' alle Blätter erzeugen und auf einmal in diese (Thisworkbook) Mappe kopieren.
' Anschließend neue Mappe schließen und sorgfältig wieder aus dem Speicher löschen
'hier die gewünschte Anzahl an Blätter eintragen:
AnzahlBlätter = 65
idx = 0
For i = 1 To AnzahlBlätter \ 30 + 1 'Teilen durch 30 ohne Rest + 1!
Set wb = Application.Workbooks.Add()
For j = 1 To 30 '30 ist beliebig aber funktioniert - wichtig ist "9.0" Then .Tab.ColorIndex = -4142 'nicht in XL2000
.Shapes("btnNeuesBlatt").Delete
.Shapes("btnFormateInRegister").Delete
.Shapes("btn AutoRep").Delete
If j > 1 Then
ReDim Preserve arrSheets(1 To UBound(arrSheets, 1) + 1)
Else
ReDim arrSheets(1 To 1)
End If
arrSheets(UBound(arrSheets, 1)) = wb.ActiveSheet.Name
End With
If idx = AnzahlBlätter Then Exit For 'wenn Blattanzahl erreicht, Schleife verlassen
Next j
For j = wb.Names.Count To 1 Step -1
wb.Names(j).Delete 'globale Namen löschen, sonst kommt die ewige Abfrage bei jedem _
Namen
Next j
wb.Sheets(arrSheets).Copy After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
wb.Close SaveChanges:=False
Set wb = Nothing
Next i
For k = ThisWorkbook.Names.Count To 1 Step -1
Set nam = ThisWorkbook.Names(k)
If Left(nam.RefersTo, 5) = "=#REF" Then
ThisWorkbook.Names(k).Delete 'Namen ohne Bezug gleich löschen
'Namen des Masterblatts als lokale Namen in alle Blätter setzen, die mit einer Zahl anfangen
ElseIf InStr(1, nam.RefersTo, "Master") > 0 Then
For Each ws In ThisWorkbook.Worksheets
If IsNumeric(ws.Name) Then
ws.Names.Add nam.Name, Replace(Replace(nam.Value, "Master", "'" & ws.Name & "'"), "''", _
"'")
End If
Next
End If
Next k
NewWS.Activate
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub