Ordner erstellen und Tabs darin abspeichern

Private Sub CommandButton1_Click() Dim i As Long Application.ScreenUpdating = False For i = 2 To Worksheets.Count Worksheets(i).Copy With ActiveSheet .Cells.Copy .Range("A1").PasteSpecial Paste:=xlPasteValues .Parent.SaveAs Filename:=ThisWorkbook.Path & "\" & _ ActiveSheet.Name & ".xls", FileFormat:=xlNormal Application.DisplayAlerts = False .Parent.Close End With Next i End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Dim LW As String, OD As String, i As Long LW = ThisWorkbook.Path & "\" OD = Worksheets("Tabelle1").Range("A1") If Dir(LW & OD, vbDirectory) = "" Then MkDir LW & OD End If Application.ScreenUpdating = False For i = 2 To Worksheets.Count Worksheets(i).Copy With ActiveSheet .UsedRange.Value = .UsedRange.Value End With With ActiveWorkbook Application.DisplayAlerts = False .SaveAs Filename:=LW & OD & "\" & _ ActiveSheet.Name & ".xls", FileFormat:=xlNormal .Close True Application.DisplayAlerts = True End With Next i

Hallo Nepumuk,
muss mich echt für die Geduld bedanken.
Folgendes:
Option Explicit
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal DirPath As String) As Long

Private Sub CommandButton1_Click()
Dim i As Long
Dim strFolederPath As String
strFolederPath = Worksheets("Tabelle1").Cells(1, 1).Text
If Right$(strFolederPath, 1)  "\" Then strFolederPath = strFolederPath & "\"
Call MakeSureDirectoryPathExists(strFolederPath)
Application.ScreenUpdating = False
For i = 2 To Worksheets.Count
Worksheets(i).Copy
With ActiveSheet
.Cells.Copy
.Range("C:\Users\xyz\Desktop\Test\Abholordner").PasteSpecial Paste:=xlPasteValues
.Parent.SaveAs Filename:=strFolederPath & _
ActiveSheet.Name & ".xls", FileFormat:=xlNormal
.Parent.Close
End With
Next i
End Sub

bei dem Part .Range("C:\Users\....usw. kommt jetzt ein Laufzeitfehler.
Hast du das so gemeint mit dem ersetzen?
Gruß Thomas

Hallo Thomas,
das könntest du so machen:

Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long

Private Sub CommandButton1_Click()
    Const FOLDER_PATH As String = "C:\Users\xyz\Desktop\Test\Abholordner\" 'Anpassen !!!
    Dim i As Long
    Dim strFolder As String
    strFolder = FOLDER_PATH & Worksheets("Tabelle1").Cells(1, 1).Text
    If Right$(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
    Call MakeSureDirectoryPathExists(strFolder)
    Application.ScreenUpdating = False
    For i = 2 To Worksheets.Count
        Worksheets(i).Copy
        With ActiveSheet
            .Cells.Copy
            .Range("A1").PasteSpecial Paste:=xlPasteValues
            .Parent.SaveAs Filename:=strFolder & _
                ActiveSheet.Name & ".xls", FileFormat:=xlNormal
            .Parent.Close
        End With
    Next i
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Ordner erstellen und Tabs darin abspeichern

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

191 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Ordner erstellen und Tabs darin abspeichern

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

191 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread