AW: Datei kopieren
07.09.2010 23:50:09
fcs
Hallo Werner,
die Reihenfolge macht man geschickter Weise etwas anders.
1. Neuen Namen angeben
2. Kopie speichern
3. Neuen Namen in Blatt 1 eintragen.
Nachfolgend ein entsprechendes Makro, das als 1. den Dialog zur Eingabe/Auswahl des Dateinamens anzeigt. Es sollte auch unter Excel 2000 funktionieren.
Das Makro kopierst du in ein allgemeines Modul deiner Persönlichen Makroarbeitsmappe PERSONL.XLS.
Anschließend kannst du es z.B. einer Schaltfläche auf einer Symbolleiste zuordnen.
Gruß
Franz
'Erstellt unter Excel 2007
Sub CopyActiveFile()
Dim wbAktiv As Workbook, vNewName As Variant, sInitialName As String
Set wbAktiv = ActiveWorkbook
'Vorgabe für neuen Namen generieren
sInitialName = "Neu " & Left(wbAktiv.Name, InStrRev(wbAktiv.Name, ".") - 1)
'Dialog zur Eingabe/Auswahl des Dateinamens anzeigen
vNewName = Application.GetSaveAsFilename(InitialFileName:=sInitialName, _
Filefilter:="Excel (*.xls;*.xlsx;*.xlsm;*.xlsb),*.xls;*.xlsx;*.xlsm;*.xlsb", _
Title:="Bitte neuen Dateinamen eingeben/auswählen")
If vNewName = False Then GoTo Beenden 'Dialog wurde abgebrochen
'Neuen Namen mit Name der aktiven Datei vergleichen
If UCase(wbAktiv.FullName) = UCase(vNewName) Then
MsgBox "Als neuer Name wurde der Name der aktiven Datei gewählt. " & vbLf _
& "Das ist nicht zulässig!", vbInformation + vbOKOnly
GoTo Beenden
End If
If Dir(vNewName) "" Then
If MsgBox("Eine Datei mit dem ausgewählten Namen existiert bereits. " & vbLf _
& "Datei """ & vNewName & """ überschreiben?", _
vbQuestion + vbOKCancel + vbDefaultButton2) = vbCancel Then
GoTo Beenden
End If
End If
'Kopie der Datei unter dem neuen Namen speichern
wbAktiv.SaveCopyAs Filename:=vNewName
'Kopie öffnen
Set wbAktiv = Workbooks.Open(Filename:=vNewName)
'Blatt 1 aktivieren und Namen in B1 eintragen
With wbAktiv
.Worksheets(1).Activate
.Worksheets(1).Range("B1") = .FullName 'name inkl. Pfad
' .Worksheets(1).Range("B1") = .Name 'nur Dateiname
.Save
End With
Beenden:
End Sub