|
Perfekt, Danke dir.
Jetzt ist es super und die 4 Stk. Makro Buttons habe ich auch noch rausgehauen.
Code wie folgt:
Sub Speichern_EPG()
Dim ord As String
Dim Dateiname As String
Dim Antwort As Integer
Dim Wert As String
Dim rngZelle As Range
Dim lngAnz As Long
Dim sh As Worksheet
Dim rng As Range
Application.ScreenUpdating = False
'prüfen ob ein Ordner vorhanden ist und falls nicht
'fragen ob Ordner erstellt werden soll
'Datei Speichern unter angegeben Pfad mit Erstellung des Ordners und Speicherung als Preisliste_SSL_Lieferanten_V0.
Wert = [A2].Value
ord = "P:\gba\abteilungen\AEC\EPLAN\Data\Projekte\KEBA AG\" & Wert & ".edb" & "\DOC" & "\Angebot"
If Dir(ord, vbDirectory) <> "" Then
MsgBox "Ein Ordner mit dem Namen Angebot ist im Verzeichnis " & ord & " schon vorhanden!"
MsgBox "Es wird kein Ordner angelegt das Dokument wird jedoch in den vorhandenen Ordner gespeichert!"
Else
Antwort = MsgBox("Der Ordner " & ord & " ist nicht vorhanden!" _
& vbNewLine _
& "Soll der Ordner angelegt werden?", vbYesNo)
If Antwort = vbYes Then
MkDir ord
MsgBox "Der Ordner " & ord & " wurde angelegt und die Datei darin gespeichert!"
Else
MsgBox "Es wurden keine Änderungen vorgenommen!"
End If
End If
ActiveWorkbook.Sheets.Copy
For Each sh In ActiveWorkbook.Worksheets
For Each rng In sh.UsedRange.Cells
rng.Formula = rng.Value
Next
Next
ActiveSheet.Shapes.Range(Array("Button 4")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("Button 3")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("Button 2")).Select
Selection.Delete
ActiveSheet.Shapes.Range(Array("Button 1")).Select
Selection.Delete
ActiveWorkbook.SaveCopyAs Filename:="P:\gba\abteilungen\AEC\EPLAN\Data\Projekte\KEBA AG\" & Wert & ".edb" & "\DOC" & "\Angebot\Preisliste_SSL_Lieferanten_V0_EPG.xlsx" _
Application.ScreenUpdating = True
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
|