AW: Excel Datei auf Netzlaufwerk spiegeln
08.07.2015 21:38:24
fcs
Hallo Julian,
das wird ziemlich kompliziert, da Excel 2 Dateien mit gleichem Namen nicht gleichzeitig öffnen kann und die Originaldatei ja ständig geöffnet bleiben soll.
Man muss deshalb den Umweg über eine temporäre Kopie mit anderem Namen gehen. Außerdem gibt es besonderheiten, wenn die Datei im älteren Dateiformat gespeichert sein sollte.
Das Makro funktioniert nicht unter Excel 2003 und älter.
Wenn unterhalb der Tabellenblätter keine Makros angelegt sind, dann könnte man ggf. alle Tabellenblätter in eine neue Datei kopieren und dann speichern.
Gruß
Franz
'Makro erstellt unter Excel 2010 / Windows Vista
'Makro muss im VBA-Editor unter dem Modul "DieseArbeitsmappe" eingefügt werden.
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Const strNetzPfad As String = "C:\Users\Public\Test\Archiv\" 'Pfad für Kopie anpassen!!!
Dim strTempName As String, strCopyName As String, strName As String, lngFormat As Long
Dim wkbCopy As Workbook
If Success = True Then
Application.EnableEvents = False
Application.ScreenUpdating = False
lngFormat = Me.FileFormat
strName = Me.Name
Select Case lngFormat
Case 52 'xlOpenXMLWorkbookMacroEnabled
'Datei ist im Format ab Excel 2007 gespeichert
strName = Left(strName, Len(strName) - 4)
strCopyName = strNetzPfad & strName & "xlsx"
strTempName = strNetzPfad & "Temp" & strName & "xlsm"
'Temporäre Kopie speichern
Me.SaveCopyAs strTempName
'Temporäre Kopie öffnen
Set wkbCopy = Workbooks.Open(strTempName)
'Temporäre Kopie ohne Makros speichern und schliessen
strTempName = strNetzPfad & "Temp" & strName & "xlsx"
Application.DisplayAlerts = False
wkbCopy.SaveAs Filename:=strTempName, FileFormat:=51
Application.DisplayAlerts = True
wkbCopy.Close savechanges:=False
'Datei in gewünschten Namen umbenennen
If Dir(strCopyName) "" Then Kill strCopyName
' Application.Wait Now+timeserial(0,0,1) 'evtl. Erforderlich
Name strTempName As strCopyName
'temporäre Kopie wieder löschen
strTempName = strNetzPfad & "Temp" & strName & "xlsm"
VBA.Kill strTempName
Case 56, -4143 ' xlExcel8,xlWorkbookNormal
'Datei ist im älteren Format gespeichert
strName = Left(strName, Len(strName) - 3)
strCopyName = strNetzPfad & strName & "xls"
strTempName = strNetzPfad & "Temp" & strName & "xls"
'Temporäre Kopie speichern
Me.SaveCopyAs strTempName
'Temporäre Kopie öffnen
Set wkbCopy = Workbooks.Open(strTempName)
'Temporäre Kopie ohne Makros im neuen Format speichern und schliessen
strTempName = strNetzPfad & "Temp" & strName & "xlsx"
Application.DisplayAlerts = False
wkbCopy.SaveAs Filename:=strTempName, FileFormat:=51
wkbCopy.Close savechanges:=False
'Makrofreie Datei wieder öffnen
Set wkbCopy = Workbooks.Open(strTempName)
'Datei wieder im alten Format speichern
strTempName = strNetzPfad & "Temp" & strName & "xls"
wkbCopy.SaveAs Filename:=strTempName, FileFormat:=-4143
wkbCopy.Close savechanges:=False
Application.DisplayAlerts = True
'Datei in gewünschten Namen umbenennen
If Dir(strCopyName) "" Then Kill strCopyName
' Application.Wait Now+timeserial(0,0,1) 'evtl. Erforderlich
Name strTempName As strCopyName
'temporäre Kopie im neuen Format wieder löschen
strTempName = strNetzPfad & "Temp" & strName & "xlsx"
VBA.Kill strTempName
Case Else
'do nothing
End Select
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub