title image


Smiley Re: Makro für generierung von Arbeitsmappen
Hallo,













Sub Tabellen_in_neue_Dateien_kopieren()

'alle Tabellen in jeweils neuer Mappe speichern

'Dateiname = Tabellenname

Dim Pfad As String  

Dim wks As Worksheet  



'Pfad anpassen

Pfad = "C:\Eigene Dateien\"

'Pfad = ThisWorkbook.Path & "\"



'prüfen ob Pfad existiert

If Dir(Pfad) = "" Then  

  MsgBox "Pfad existiert nicht", , "Abbruch"

  Exit Sub  

End If  



On Error GoTo Fehler    



Application.ScreenUpdating = False

'eventuell vorhandene Datei ohne Rückfrage überschreiben

Application.DisplayAlerts = False



For Each wks In ThisWorkbook.Worksheets  

    ThisWorkbook.Worksheets(wks.Name).Copy

    ActiveWorkbook.SaveAs (Pfad & wks.Name)

    ActiveWorkbook.Close

Next wks



Application.DisplayAlerts = True

Application.ScreenUpdating = True



MsgBox "alle Tabellen gespeichert in" & vbNewLine & vbNewLine _

        & Pfad, , ""



Exit Sub  



Fehler:

    Application.ScreenUpdating = True

    Application.DisplayAlerts = True



    MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _

    & "Beschreibung: " & Err.Description _

    , vbCritical, "Fehler"

End Sub  









Gruß

Alfons

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: