Speichern unter ...wenn...

Hallo alle zusammen,
ich habe eine Excel Mappe Namens "Budget 2005" wo Daten von mehreren Abteilungen eingetragen werden. In einer Tabelle Namens "Budget" steht in Zelle A1 das entsprechende Jahr "2005". Danach richtet sich die Gültigkeit von bestimmten Zellen für die Abteilungen und andere Werte. Nun möchte ich gern mit VBA erreichen, dass wenn immer das nächste Jahr eingetragen wird, die Datei im selben Ordner unter Budget 2006 u.s.w.gespeichert wird, damit die Ursprungsdatei erhalten bleibt vielleicht noch eine Meldung vor der Speicherung: "Soll die Datei unter Budget 2006 gespeichert werden". Bei ja-speichern, bei nein- nicht speichern. Ich hoffe mir kann jemand helfen.
Danke im voraus!

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim fn As String If Not Intersect(Range("A1"), Target) Is Nothing Then If Range("A1") < 1999 Or Range("A1") > 2100 Then 'kein gültiger Wert MsgBox "Jahreszahl muss zwischen 1999 und 2100 liegen!" With Application .EnableEvents = False .Undo .EnableEvents = True End With Else 'Wert OK fn = ThisWorkbook.Path & "\" & ActiveSheet.Name & " " & Range("A1") & ".xls" If MsgBox("Die Datei wird gespeichert unter " & fn & vbLf & _ "Fortfahren?", vbQuestion + vbOKCancel, "Sicherheitsabfrage") = vbOK Then 'Datei speichern Application.EnableEvents = False On Error Resume Next ThisWorkbook.SaveAs Filename:=fn If Err.Number > 0 Then 'Fehler beim Speichern MsgBox Err.Description, vbCritical, "Fehler Nr. " & Err.Number Err.Clear With Application .EnableEvents = False .Undo .EnableEvents = True End With Else MsgBox "Datei wurde gespeichert unter " & ThisWorkbook.FullName, vbInformation End If Application.EnableEvents = True Else With Application .EnableEvents = False .Undo .EnableEvents = True End With End If End If End If End Sub

Hallo Matthias,
danke es funktioniert. Ich habe noch etwas hinzugefügt, dass in dem Shett("NSM Empfang HR") der Bereich B5:I3000 gelöscht wird. Kannst du mir sagen warum nichts gelöscht wird. Das ein und ausblenden funktioniert doch auch.
Danke für deine mühe!


Private Sub Worksheet_Change(ByVal Target As Range)
Dim fn As String
If Not Intersect(Range("A1"), Target) Is Nothing Then
If Range("A1") < 1999 Or Range("A1") > 2100 Then
'kein gültiger Wert
MsgBox "Jahreszahl muss zwischen 1999 und 2100 liegen!"
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
Else
'Wert OK
fn = ThisWorkbook.Path & "\" & ActiveSheet.Name & " " & "FY" & " " & Range("A1") & ".xls"
If MsgBox("Die Datei wird gespeichert unter " & fn & vbLf & _
"Fortfahren?", vbQuestion + vbOKCancel, "Sicherheitsabfrage") = vbOK Then
'Datei speichern
Application.EnableEvents = False
On Error Resume Next
ThisWorkbook.SaveAs Filename:=fn
If Err.Number > 0 Then
'Fehler beim Speichern
MsgBox Err.Description, vbCritical, "Fehler Nr. " & Err.Number
Err.Clear
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
Else
MsgBox "Datei wurde gespeichert unter " & ThisWorkbook.FullName, vbInformation
End If
Application.EnableEvents = True
Else
With Application
.EnableEvents = False
.Undo
.EnableEvents = True
End With
End If
End If
End If
Sheets("NSM Empfang HR").Visible = True
Sheets("NSM Empfang HR").Select
Range("B5:I3000").Select
Selection.ClearContents
Range("B5").Select
Sheets("NSM Empfang HR").Visible = xlVeryHidden
End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim fn As String If Not Intersect(Range("A1"), Target) Is Nothing Then If Range("A1") < 1999 Or Range("A1") > 2100 Then 'kein gültiger Wert MsgBox "Jahreszahl muss zwischen 1999 und 2100 liegen!" With Application .EnableEvents = False .Undo .EnableEvents = True End With Else 'Wert OK fn = ThisWorkbook.Path & "\" & ActiveSheet.Name & " " & Range("A1") & ".xls" If MsgBox("Die Datei wird gespeichert unter " & fn & vbLf & _ "Fortfahren?", vbQuestion + vbOKCancel, "Sicherheitsabfrage") = vbOK Then 'Bereich löschen Sheets("NSM Empfang HR").Range("B5:I3000").ClearContents 'Datei speichern Application.EnableEvents = False On Error Resume Next ThisWorkbook.SaveAs Filename:=fn If Err.Number > 0 Then 'Fehler beim Speichern MsgBox Err.Description, vbCritical, "Fehler Nr. " & Err.Number Err.Clear With Application .EnableEvents = False .Undo .EnableEvents = True End With Else MsgBox "Datei wurde gespeichert unter " & ThisWorkbook.FullName, vbInformation End If Application.EnableEvents = True End If End If End If End Sub

Beliebteste Forumthreads (12 Monate)

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread