AW: Dateiname ... Anhang...
31.01.2006 17:28:33
Joachim Röder
Hallo,
das -Problem- ist schon vorher aufgetreten.
Hans hat nur den Pfad geändert auf c:\.
Es soll folgendes geschehen:
Die Tabelle 1 (analyse) soll nur im Bereich a1 bis O101 als Tabellenblatt (Ergebnis) ohne Formeln - Makros oder dergleichen genauso formatiert mit ungesperrten Zellen als selbständige Mappe gespeichert werden.
Als erstes Verzeichnis soll c:\ vorgeschlagen werden.
Wenn der Nutzer dann sein Zielverzeichnis ausgewählt hat, soll dieses beim nächsten speichern als erstes Verzeichnis vorgeschlagen werden.
Der vorgeschlagene Dateiname soll sein: Name der Mappe (Ergebnis) und Eintrag in Zelle E1.xls
Z.B. Eintrag in E1 = Meier - dann wäre der Dateiname: Ergebnis Meier.xls
Wenn beim Speichern in Zelle E1 kein Eintrag ist soll die Meldung: sie müssen einen Eintrag in Zelle E1 vornehmen - kommen. Erst dann ist das Speichern möglich. nach bestätigen dier Message springt der Cursoer automatisch in die Zelle E1 und wartet auf die Eingabe.
Die Option Speichern unter... im Programmmenü Datei... soll nicht ausgeführt werden können. -Hier heisst es: Datei kann nicht unter einem anderen Namen gespeichert werden.
Dadurch sollen Kopien der Mappe vermieden werden, da durch die rechnergebundene Initialisierung sonst bei einem Hardwarewechsel unter Umständen eine große Zahl von Arbeitsmappen nicht mehr gestartet werden können.
Die gespeicherte AuswertungXXX.xls hat als Inhalt nur die Werte aus der Berechnung Analyse. Keine Formeln ect. Das optische Aussehen soll allerdings erhalten bleiben.Die so gespeicherte Tabelle (Ergebnis) kann nach Herzenlust bearbeitet und formatiert werden.
Alle Funktionen der Mappe sind OK. Nur die Funktion des CommandButton Speichern der Auswertung unter.... ist nicht richtig.
Es wird nur der Blatt- = Dateiname - Ergebnis.xls vorgeschlagen die Dateinamenwerweiterung =Wert aus Zelle E1 wird nicht mitgegeben.
Anschließend soll die Mappe Ergebnis geschlossen werden.
Hier der daür verwendete Code des Speichern unter - Buttons:
-------------------
Option Explicit
Private Declare
Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" ( _
ByVal pszPath As String) As 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")
If strFileName = "C:\" 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 = "Ergebnis"
.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
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
-------------------------
Ich hoffe, dass der Fehler im Code gefunden wird.
Viele Grüße
Joachim