Speichern unter Makro

Hallo zusammen,
ich bräuchte mal Hilfe. Und zwar brauch ich ein Makro, das eine Exceldatei unter einem bestimmten Namen aus zwei verschiedenen Feldern (D3 und B5) innerhalb der Tabelle (Arbeitsblatt"Befragung")an einem bestimmten Ort abspeichert.
Ich befrage ca. 100 Personen und möchte damit sicherstellen, das eine strukturierte Dateiablage sichergestellt ist. Bestenfalls kann der "Nutzer" auf Speichern klicken und dann wird die Datei entsprechend gespeichert und einmal ausgedruckt, optimal wäre es wenn dann noch im Ausdruck der Speicherort (Datum/Uhrzeit) steht.
Da ich leider kaum VBA-Kenntnisse habe würde ich mich über jegliche Art der Hilfe etxtrem doll freuen.
Vielen Dank und liebe Grüße
Henning

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) On Error GoTo Fehler Cancel = True Dim Pfad$, Datei$ Pfad = "Q:\100_Vollzugriff\EREIGNISSYSTEM\" With Sheets("Befragung") Datei = .Range("D3") & "_" & .Range("B5") & "_" & Format(Now, "YYYYMMDDhhmm") & ".xlsx" .PageSetup.LeftFooter = Pfad & Datei .PageSetup.RightFooter = Format(Now, "DD.MM.YYYY hh:mm") Application.EnableEvents = False ActiveWorkbook.SaveAs Filename:=Pfad & Datei, _ FileFormat:=xlOpenXMLWorkbook .PrintOut End With Err.Clear Fehler: Application.EnableEvents = True If Err.Number <> 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0

Option Explicit Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) On Error GoTo Fehler Cancel = True Dim Pfad$, Datei$ Pfad = "C:\Temp\" With Sheets("Befragung") Datei = .Range("D3") & "-" & .Range("B5") & ".xlsm" .PageSetup.LeftFooter = Pfad & Datei .PageSetup.RightFooter = Format(Now, "DD.MM.YYYY hh:mm") Application.EnableEvents = False ActiveWorkbook.SaveAs Filename:=Pfad & Datei, _ FileFormat:=xlOpenXMLWorkbookMacroEnabled .PrintOut End With Err.Clear Fehler: Application.EnableEvents = True If Err.Number <> 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0

Hallo
das Problem ist:
Wenn DU die ursprumgsdatei mit dem jetzt geänderten Makro speichern möchtest, dann läuft auch des "BeforeSave" ab.
Wenn du dieses Makro zum speichern der Datei selbst benutzt, müsste es gehen.

Sub Speicher_mich()
    On Error Resume Next
    Application.EnableEvents = False
    ActiveWorkbook.SaveAs FileFormat:=xlOpenXMLWorkbookMacroEnabled
    Application.EnableEvents = True
    
End Sub

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0

Oder eben wie du schon geschrieben hast, das "User_Speichern" auf einen Button legen.
in ein Modul.

Sub User_Speichern()
    On Error GoTo Fehler
    Dim Pfad$, Datei$
    Pfad = "C:\Temp\"
    With Sheets("Befragung")
        Datei = .Range("D3") & "-" & .Range("B5") & ".xlsx"
        .PageSetup.LeftFooter = Pfad & Datei
        .PageSetup.RightFooter = Format(Now, "DD.MM.YYYY hh:mm")
        ActiveWorkbook.SaveAs Filename:=Pfad & Datei, _
            FileFormat:=xlOpenXMLWorkbook
        .PrintOut
    End With
    Err.Clear
Fehler:
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & vbLf & Err.Description: Err.Clear
End Sub

Gruß UweD

Sub User_Speichern() On Error GoTo Fehler Dim Pfad$, Datei$ Pfad = "Q:\100_Vollzugriff\EREIGNISSYSTEM\" With Sheets("Befragung") If .Range("D3") = "" And .Range("B5") = "" Then 'Prüfung MsgBox "Bitte die Felder füllen" Else .Copy Datei = .Range("D3") & "_" & .Range("B5") & "_" & Format(Now, "YYYYMMDDhhmm") & ".xlsx" .PageSetup.LeftFooter = Pfad & Datei .PageSetup.RightFooter = Format(Now, "DD.MM.YYYY hh:mm") ActiveWorkbook.SaveAs Filename:=Pfad & Datei, _ FileFormat:=xlOpenXMLWorkbook .PrintOut ActiveWorkbook.Close False End If End With Err.Clear Fehler: If Err.Number <> 0 Then MsgBox "Fehler: " & _ Err.Number & vbLf & Err.Description: Err.Clear End Sub VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0

Beliebteste Forumthreads (12 Monate)

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread