Hier das Makro
26.05.2006 19:46:35
Walter
Hallo Klaus,
hier das Makro, mit einem Button läuft. In einer Sheet "ww" hatte ich reinkopiert,
konnte aber später nicht mit dem Button starten, Verbindung war immer zur Ursprungsmappe.
Ich möchte also, wenn die neue Mappe angelegt ist, das ich mit der neuen Mappe auch das Makro ausführen kann.
Makro:
Sub A_Test_SheetToFile()
Dim strPath As String
Dim objSh As Worksheet
Dim objWb As Workbook
Dim blnExist As Boolean, blnClose As Boolean
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
strPath = "C:\Muster\" ' Anpassen!
Set objSh = ActiveSheet
If Dir(strPath & objSh.Name & ".xls") <> "" Then
blnExist = True
If MsgBox("Die Datei" & vbLf & vbLf & vbTab & Chr(34) & strPath & objSh.Name & ".xls" & Chr(34) & _
Space(15) & vbLf & vbLf & "ist bereits vorhanden!" & vbLf & vbLf & _
"Soll die Datei ersetzt werden!", 36, "Frage") = 7 Then
blnClose = True
GoTo ErrExit
End If
End If
For Each objWb In Workbooks
If objWb.FullName = strPath & objSh.Name & ".xls" Then
If MsgBox("Die Datei" & vbLf & vbLf & vbTab & Chr(34) & objWb.FullName & Chr(34) & _
Space(15) & vbLf & vbLf & "ist zur Zeit geöffnet!" & vbLf & vbLf & _
"Um mit fortzufahren, muss die Datei geschlossen werden!", 33, "Frage") = 2 Then
blnClose = True
GoTo ErrExit
End If
objWb.Close False
Exit For
End If
Next
objSh.Copy
With ActiveWorkbook
.SaveAs strPath & objSh.Name & ".xls"
.Close True
End With
ErrExit:
If Err.Number = 0 Then
If blnClose Then
MsgBox "Der Vorgang wurde Abgebrochen!", 64, "Hinweis"
Else
MsgBox "Die Datei" & vbLf & vbLf & vbTab & strPath & objSh.Name & ".xls" & Space(15) & _
vbLf & vbLf & "wurde erfolgreich " & IIf(blnExist, "ersetzt", "erstellt") & "!", 64, "Hinweis"
End If
Else
MsgBox "Beim speichern der Datei" & vbLf & vbLf & vbTab & strPath & objSh.Name & ".xls" & Space(15) & _
vbLf & vbLf & "trat folgender Fehler auf" & vbLf & vbLf & Err.Description & Space(15), 48, "Fehler"
Err.Clear
End If
Set objSh = Nothing
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
mfg walter