Speichern ohne Makro
29.01.2013 14:55:25
SoulOpa
ich habe eine Frage bezüglich des oberen stehenden Makro. Dieser VBA Code speichert meine kommplette Arbeitsmappe in dem vor gegebenen Verzeichnis. Der Speicher Name wird aus Tabelle 1 von Zelle J6 so wie T4 ausgelesen und gespeichert. (Klappt so weit super)
Aber ich benötige nur eine Kopie von der kommpletten Mappe ohne Makros! was und wo muss ich hier ändern? Die Original Arbeitsmappe wo die Angebote erstellt werden, soll weiterhin mit Makros unverändert bleiben.
'*******************************************
'Dialog für Speichern_unter wird geöffnet *
'*******************************************
Dim Pfad$, Datei$, Filter$, Endg$, File
Pfad = "C:\MJ\Angebote\"
Datei = ActiveSheet.Range("J6") & " " & Range("T4")
If Datei = "" Then
MsgBox "Zelle enthält keinen Eintrag"
Exit Sub
End If
Endg = ".xls"
If InStr(Datei, Endg) = 0 Then 'Prüfung ob Zelle bereits Endung enthält
Datei = Datei & Endg
End If
Filter = "Excel Files (*" & Endg & "), *" & Endg
File = Application.GetSaveAsFilename(Pfad & Datei, Filter)
If File False Then ActiveWorkbook.SaveAs Filename:=File
End Sub
Hier mal mein Kommpletter Code von Tabelle1
Option Explicit
'********************************
'Drucken aller Tabellenblätter *
'********************************
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
If MsgBox("Ihr Angebot wird jetzt erstellt und Gedruckt? Wollen Sie dieses durchführen? ", _
vbInformation + vbYesNo) = 7 Then Exit Sub
Sheets("Tabelle1").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Sheets("Tabelle2").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Sheets("Tabelle3").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Sheets("Tabelle4").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Sheets("Tabelle5").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Sheets("Tabelle2").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Sheets("Tabelle3").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Sheets("Tabelle4").Select
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
Sheets("Tabelle1").Select
Range("A1").Select
Application.ScreenUpdating = True
'*********************************************************************************************** _
'Automatische Auftragsnummer vergabe. AG Nr. wird am nächsten Werktag Automatisch auf 1 zurück _
gesetzt *
'*********************************************************************************************** _
If Date > DateSerial(Mid(Range("T4"), 8, 4), Mid(Range("T4"), 6, 2), Mid(Range("T4"), 4, 2)) _
Then
Range("T4") = Replace("MM-" & Date & "-1", ".", "", 1)
Else
Range("T4") = Left(Range("T4"), 12) & (Mid(Range("T4"), 13, 9 ^ 9) * 1) + 1
End If
'Blendet eine Msgbox nach 1 Sekunden automatisch wieder aus *
Const bytZeit As Byte = 1
Dim objWSH As Object, intMSG As Integer
Set objWSH = CreateObject("WScript.Shell")
intMSG = objWSH.Popup("Ihr Angebot wurde fertig gestellt und gedruckt!!! Bitte Warten" & _
Space(10), bytZeit, "Angebot Fertig Stellen")
Set objWSH = Nothing
'Dialog für Speichern_unter wird geöffnet *
Dim Pfad$, Datei$, Filter$, Endg$, File
Pfad = "C:\MJ\Angebote\"
Datei = ActiveSheet.Range("J6") & " " & Range("T4")
If Datei = "" Then
MsgBox "Zelle enthält keinen Eintrag"
Exit Sub
End If
Endg = ".xls"
If InStr(Datei, Endg) = 0 Then 'Prüfung ob Zelle bereits Endung enthält
Datei = Datei & Endg
End If
Filter = "Excel Files (*" & Endg & "), *" & Endg
File = Application.GetSaveAsFilename(Pfad & Datei, Filter)
If File False Then ActiveWorkbook.SaveAs Filename:=File
End Sub
Ich danke für Eure Hilfe.
mfg Andi