AW: Suche ein Makro
23.07.2015 22:14:34
Sepp
Hallo Michl,
gut, aber trotzdem mit Sicherung.
In ein allgemeines Modul.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
#If Win64 Then
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As LongLong
#Else
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As Long
#End If
Sub saveTemplate()
Dim strFile As String, strFolder As String, strRoot As String
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlManual
.DisplayAlerts = False
End With
strRoot = "C:\Protokolle"
If Right(strRoot, 1) <> "\" Then strRoot = strRoot & "\"
With Sheets("Tabelle1") 'Tabellenname anpassen!
strFolder = strRoot & .Range("E5").Text & "\"
If Not FolderExists(strFolder) Then
MakeSureDirectoryPathExists strFolder
End If
strFile = Format(.Range("B35"), "yyyyMMdd") & ".xlsx"
If FileExists(strFolder & strFile) Then
MsgBox "Die Datei '" & strFolder & strFile & "' ist schon vorhanden!", vbExclamation
Else
.Copy
ActiveWorkbook.SaveAs strFolder & strFile, xlWorkbookNormal
ActiveWorkbook.Close True
End If
End With
ErrExit:
With Err
If .Number <> 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'saveTemplate'" & vbLf & String(60, "_") & _
vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
"Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
.Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
"VBA - Fehler in Prozedur - saveTemplate"
.Clear
End If
End With
On Error GoTo 0
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlAutomatic
.DisplayAlerts = True
.StatusBar = False
End With
End Sub
Private Function FolderExists(FolderName As String) As Boolean
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
FolderExists = objFSO.FolderExists(FolderName)
Set objFSO = Nothing
End Function
Private Function FileExists(FileName As String) As Boolean
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
FileExists = objFSO.FileExists(FileName)
Set objFSO = Nothing
End Function
Gruß Sepp