Speichern unter Zellinhalt per VBA

Private Sub ArbeitSpeichern_Click()
Dim spaArray As Variant
Dim i As Integer
Dim n As Integer
Dim strFileNameCopy As String, strLinkCompare
Dim rng As Range, rngFormula As Range
Dim wbCopy As Workbook
' Bildschirmaktualisierung unterdrücken
Application.ScreenUpdating = False
' Dateinamen für Kopie der Mappe festlegen
strFileNameCopy = "D:\Sascha\Excel\Gravurlisten\" & _
Sheets("Artikel").Range("D8") & ".xls"
' Kopie erstellen
ThisWorkbook.SaveCopyAs strFileNameCopy
' Kopie öffnen
Workbooks.Open strFileNameCopy
spaArray = Array("D", "E", "F", "G", "H", "I", "J", "K", "L", _
"M", "N", "O", "P", "Q", "R", "S")
' zunächst den Mappen- und Blattschutz aufheben
' dies kann entfallen, wenn die Quellmappe keinen
' Schutz aufweist
ActiveWorkbook.Unprotect
For i = 1 To Sheets.Count
Sheets(i).Unprotect
Next i
' Spalten ausblenden
For i = 2 To Worksheets.Count
For n = LBound(spaArray) To UBound(spaArray)
With Worksheets(i).Columns(spaArray(n))
' Spalte ausblenden, wenn die erste Zelle der Spalte leer
' ist oder den String "0" enthält
.Hidden = (IsEmpty(.Cells(1)) Or .Cells(1) = "0")
End With
Next n
Next i
' Verknüpfungen auf das Artikelblatt entfernen
' es wird vorausgesetzt, das dieses Blatt das erste der
' Blattaufzählung ist
' Vergleichsstring zusammensetzen
strLinkCompare = "=" & Worksheets(1).Name & "!*" ' liefert "=Artikel!*"
For i = 2 To Worksheets.Count
With Worksheets(i).Cells
' Wenn ein Blatt keine Formeln enthält, entsteht bei
' Anwendung der SpecialCells-Methode ein Laufzeitfehler
' der abgefangen werden muß
On Error Resume Next
Set rngFormula = .SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
' alle Zellen mit Formeln durchlaufen
If (Not rngFormula Is Nothing) Then
For Each rng In rngFormula
' falls eine Verknüpfung enthalten ist
If (rng.Formula Like strLinkCompare) Then
' dann die Formel durch den Zellwert ersetzen
' dadurch wird die Verknüpfung entfernt
rng.Formula = rng.Value
End If
Next
End If
End With
Next i
' Warnungen deaktivieren
Application.DisplayAlerts = False
' erstes Blatt der Mappe entfernen
Worksheets(1).Delete
' wenn "I18" im ersten Blatt leer, dann Blatt "Auswertung CalcCase" löschen
If [I18].Value = "" Then
Sheets("Auswertung_CalcCase_farbig").Delete
End If
' Warnungen aktivieren
Application.DisplayAlerts = True
' Schutz setzen
For i = 1 To Sheets.Count
Sheets(i).Protect , DrawingObjects:=True, _
Contents:=True, Scenarios:=True
Sheets(i).EnableSelection = xlUnlockedCells
Next i
ActiveWorkbook.Protect , Structure:=True, Windows:=False
' Warnungen deaktivieren
Application.DisplayAlerts = False
' neu speichern im Excel97-Format
ActiveWorkbook.SaveAs Filename:=strFileNameCopy, FileFormat:=xlExcel9795
' Warnungen wieder aktivieren
Application.DisplayAlerts = True
' Kopie schliessen
ActiveWorkbook.Close
' Warnungen deaktivieren
Application.DisplayAlerts = False
' Original schliessen
ActiveWorkbook.Close
' Warnungen wieder aktivieren
Application.DisplayAlerts = True
' Bildschirmaktualisierung wieder anzeigen
Application.ScreenUpdating = True
End Sub