Sheet kopieren und dann...

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Walter!
Kein Problem!

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Hallo Walter!
Von Vater zu Vater als Vatertagsgeschenk ;-))

' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub 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:\Werkstatt\" ' 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

'******************************
'* Gruß Sepp
'*
'* Rückmeldung wäre nett!
'******************************

Beliebteste Forumthreads (12 Monate)

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread