Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
724to728
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
724to728
724to728
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Datei Speichern.....

Datei Speichern.....
02.02.2006 13:41:40
Joachim
Hallo,
ich habe eine Datei bei der ich verhindere, dass diese unter einem anderen Namen gespeichert werden kann. Also nicht speichern unter im Menü Datei.
Um EIN Tabellenbaltt zu speichern habe ich einen Code bekommen der bewirkt, dass das erste Tabellenblatt mit dem Namen Ergebnis und dem Zusatz des Inhaltes aus Feld E1 als neue Arbeitsmappe gespeichert werden kann.
Diese Mappe enthält eben nur dieses eine Blatt mit Werten jedoch ohne Formel und Makros.
Soweit so gut... funktioniert.
Nun habe ich noch 2 probleme:
1.) Wenn ich das Blatt als neue Mappe Speichern will schlägt mit Excel als Speicherort C:\Dokumente und Einstellungen\(benutzer)\Eigene Dateien vor.
Nun möchte ich verhindern, dass man immer wieder sich durch die verschiedenen Ordner hanglen muss um ggf. 7-8 Ebenen tiefer endlich an dem Ordner angekommen ist, in dem gespeichert weden soll.
Für das erste mal ist das auch OK.
Doch ich möchte, dass sich die Tabelle den letzten gewählten Ornder merkt und diesen als Vorgabe bei der nächsten Speicheraktion vorschlägt.
Das funktioniert auch so lange ich Excel nicht wieder schließe.
Wenn aber Excel geschlossen wurde und ich die Tabelle neu starte wird mir wieder
C:\Dokumente und Einstellungen\(benutzer)\Eigene Dateien vorgeschlagen.
Kann man es einricten, dass der letzte Speicherort als erstes Verzeichnis vorgeschlagen wird?
2.) Das Problem in diesem Code ist auch noch, dass nicht ALLE Makros gelöscht werden. Hierzu habe ich auch schon in einem anderen Thread einiges diskutiert jedoch ohne Erfolg.
-------------------------
Hier der Code in Tabelle 1 ,der sich um das Speichern kümmert....
Option Explicit
Option Private Module
Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" ( _
ByVal pszPath As String) As Long

Private Sub Speichern_BeiKlick()
Dim objWb As Workbook, objMe As Worksheet
Dim objVBComp As Object
Dim objShape As Shape
Dim objName As Name
Dim strFileName As String, strPath As String
Dim rng As Range
Dim lngResult As Long
Set objMe = Sheets("ANALYSE")
strFileName = Range("E1")
If strFileName = "" Then
MsgBox "Bitte geben sie dieser Auswertung einen Namen!" & Space(20) & vbLf & _
"Unter diesem Namen wird die Auswertung gespeichert." & Space(20) & vbLf & _
" " & Space(20) & vbLf & _
"Der Vorgang wird abgebrochen!", 64, "Hinweis"
Application.Goto objMe.Range("E1")
Exit Sub
End If
strFileName = strFileName & ".xls"
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
objMe.Copy
Set objWb = ActiveWorkbook
With objWb
.Sheets(1).Name = "Auswertung"
.Sheets(1).Unprotect
On Error Resume Next
For Each rng In .Sheets(1).Cells.SpecialCells(xlCellTypeFormulas, 23) 'Formel in Werte
rng = rng.Value
Next
For Each rng In .Sheets(1).Cells.SpecialCells(xlCellTypeAllFormatConditions) 'Bedingte Formatierung entfernen
rng.FormatConditions(1).Delete
rng.FormatConditions(2).Delete
rng.FormatConditions(3).Delete
Next
.Sheets(1).Cells.SpecialCells(xlCellTypeAllValidation).Validation.Delete 'Gültigkeiten entfernen
Err.Clear
On Error GoTo ErrExit
.Sheets(1).Range("P1:IV65536").Delete
.Sheets(1).Range("A102:IV65536").Delete
.Sheets(1).Range("A1:O101").Interior.ColorIndex = xlNone
For Each objName In .Names 'Definierte Namen entfernen
objName.Delete
Next
On Error Resume Next
For Each objVBComp In .VBProject.VBComponents 'VBA-Code entfernen
With objVBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
Next
Err.Clear
For Each objShape In .Sheets(1).Shapes 'Schaltflächen/Shapes entfernen
objShape.Delete
Next
lngResult = Application.Dialogs(xlDialogSaveAs).Show(strPath & "Ergebnis " & strFileName)
If lngResult = 0 Then
.Close False
MsgBox "Vorgang abgebrochen!", 64, "Abbruch"
Else
strFileName = .FullName
objMe.Parent.Names("Pfad").Value = "=" & .Path & "\"
.Close True
End If
End With
If lngResult <> 0 Then
Set objWb = Workbooks.Open(strFileName)
With objWb
On Error Resume Next
For Each objVBComp In .VBProject.VBComponents 'VBA-Code entfernen
With objVBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
Next
Err.Clear
.Save
.Close True
End With
End If
ErrExit:
Set objWb = Nothing
If Err.Number > 0 Then
MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
Err.Clear
End If
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
End Sub

--------------------
Gruß
Joachim

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

Betreff
Datum
Anwender
Anzeige
AW: Datei Speichern.....
02.02.2006 15:47:44
Fred
Hi,
entweder den Pfad in der mappe speichern(Dateieigenschaften, Tabelle) oder in der
Registry(SaveSetting).
On Error Resume Next
For Each objVBComp In .VBProject.VBComponents 'VBA-Code entfernen
With objVBComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
Next
Err.Clear
Lass zunächst die On Error-Anweisung weg und prüfe, ob da ev. ein Fehler auftritt.
mfg Fred
AW: Datei Speichern.....
02.02.2006 17:50:08
Joachim
Hallo,
also -OnError rausgenommen...
Keine Fehlermeldung..
Auf meinem Masterrechner werden alle Makros - wie gehabt gelöscht.
Auf dem anderen Rechner bleibt das Makro der Tabelle 1 erhalten......?
---------------
Wie bekomme ich es hin, dass der zuletzt genutzte Pfad in der Mappe gespeichert wird?
Denn genau das ist es ja, was ich möchte.
Das Makro zum speichern habe ich ja mitgesandt.
------------
Gruß
Jo
Anzeige
AW: Datei Speichern.....
02.02.2006 20:03:00
HansHei
Hallo Joachim,
ich denke soweit warst Du schon einmal?


Option Explicit
Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" ( _
  ByVal pszPath As StringAs Long
Sub Speichern_BeiKlick()
Dim objWb As Workbook, objMe As Worksheet
Dim objVBComp As Object
Dim objShape As Shape
Dim objName As Name
Dim strFileName As String, strPath As String
Dim rng As Range
Dim lngResult As Long
Set objMe = Sheets("ANALYSE")
strFileName = Trim$(objMe.Range("E1"))
strPath = Mid(objMe.Parent.Names("Pfad").RefersToLocal, 2)
If PathIsDirectory(strPath) = 0 Then strPath = "C:\"
If strFileName = "" Then
  MsgBox "Bitte Eintrag in Zelle[E1] vornehmen!" & Space(20) & vbLf & _
    "Der Vorgang wird abgebrochen!", 64, "Hinweis"
  Exit Sub
End If
strFileName = strFileName & ".xls"
On Error GoTo ErrExit
With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
End With
objMe.Copy
Set objWb = ActiveWorkbook
With objWb
  .Sheets(1).Name = "Ergebnis"
  .Sheets(1).Unprotect "abc" ' wenn ohne Passwort geschützt, dann .Sheets(1).Unprotect !
  On Error Resume Next
  For Each rng In .Sheets(1).Cells.SpecialCells(xlCellTypeFormulas, 23) 'Formel in Werte
    rng = rng.Value
  Next
  For Each rng In .Sheets(1).Cells.SpecialCells(xlCellTypeAllFormatConditions) 'Bedingte Formatierung entfernen
    rng.FormatConditions(1).Delete
    rng.FormatConditions(2).Delete
    rng.FormatConditions(3).Delete
  Next
  .Sheets(1).Cells.SpecialCells(xlCellTypeAllValidation).Validation.Delete 'Gültigkeiten entfernen
  Err.Clear
  On Error GoTo ErrExit
  .Sheets(1).Range("P1:IV65536").Delete
  .Sheets(1).Range("A101:IV65536").Delete
  .Sheets(1).Range("A1:O100").Interior.ColorIndex = xlNone
  For Each objName In .Names 'Definierte Namen entfernen
    objName.Delete
  Next
  For Each objVBComp In .VBProject.VBComponents 'VBA-Code entfernen
    With objVBComp.CodeModule
      .DeleteLines 1, .CountOfLines
    End With
  Next
  For Each objShape In .Sheets(1).Shapes 'Schaltflächen/Shapes entfernen
    objShape.Delete
  Next
  lngResult = Application.Dialogs(xlDialogSaveAs).Show(strPath & "Ergebnis " & strFileName)
  If lngResult = 0 Then
    .Close False
    MsgBox "Vorgang abgebrochen!", 64, "Abbruch"
  Else
    strFileName = .FullName
    objMe.Parent.Names("Pfad").Value = "=" & .Path & "\"
    .Close True
  End If
End With
If lngResult <> 0 Then
  Set objWb = Workbooks.Open(strFileName)
  With objWb
    For Each objVBComp In .VBProject.VBComponents 'VBA-Code entfernen
      With objVBComp.CodeModule
        .DeleteLines 1, .CountOfLines
      End With
    Next
    .Save
    .Close True
  End With
End If
ErrExit:
Set objWb = Nothing
If Err.Number > 0 Then
  MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
  Err.Clear
End If
With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
End With
End Sub
Gruß
Hans
Anzeige
AW: Datei Speichern.....
03.02.2006 12:39:58
Joachim
Hallo,
vielen Dank -Hans- du hast recht irgendwie war ich schon mal soweit, doch irgendetwas ist anders (Was?) - egal - ES LÄUFT..... so wie es sein soll.
--------------
Nur das Problem mit der Gültigkeitsregel ist noch immer da.
Ich habe bereits dafür einen sep. Thread eröffnet.
Viele Grüße aus Düsseldorf
Joachim

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige