Unterordner und Arbeitsmappe erstellen

Hallo,
ich bräuchte wieder mal einen Schubser weil ich keinen Plan habe wie man folgendes machen könnte:
Ich möchte in dem Ordner, in dem sich meine Datei befindet, einen Unterordner erstellen.
Meine Überlegungen dazu: Prüfen, ob der Unterordner existiert, wenn nicht, erstellen
Es funktioniert natürlich so nicht...
If Dir("C:\und hier der Pfad des Ordners") = "" Then
Set NeuerOrdner = CreateObject("Scripting.FileSystemObject").GetFolder("C:\und hier der Pfad des Ordners").SubFolders.Add("Unterordner")
Für jeden Namen im Bereich A1:A15 ein neues Tabellenblatt mit dem jeweiligen Namen in der neuen Datei erstellen. Wahrscheinlich in einer For Next Schleife...grübel

Set neuesWB = Workbooks.Add
Mehr weiß ich leider noch nicht und mit den Beipielen aus dem Archiv habe ich so meine Probleme.
Für einen Ansatz wäre ich Euch echt dankbar, auch wenn ich hier wahrscheinlich etwas zuviel verlange.
Viele Grüße
Werner

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Dim liZeile As Integer With ThisWorkbook For liZeile = 1 To 15 If .Sheets(1).Range("A" & liZeile).Value "" Then .Sheets.Add after:=.Sheets(.Sheets.Count) ActiveSheet.Name = .Sheets(1).Range("A" & liZeile).Value End If Next End With

Hallo Werner,
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As Long

Sub MakeFileAndDirectory()
    Dim objWb As Workbook
    Dim rng As Range
    Dim strPath As String, strNewFolder As String, strFileName As String

    On Error GoTo ErrExit
    GMS

    strNewFolder = "NeuerOrdner" 'anpassen!
    strFileName = "neu.xls" 'anpassen!

    strPath = ThisWorkbook.Path & "\" & strNewFolder & "\"

    MakeSureDirectoryPathExists strPath

    Set objWb = Workbooks.Add(xlWBATWorksheet)

    With objWb
        For Each rng In ThisWorkbook.Sheets("Tabelle1").Range("A1:A15") 'anpassen
            If rng.Text <> "" Then
                .Worksheets.Add after:=.Sheets(.Sheets.Count)
                .Sheets(.Sheets.Count).Name = rng.Text
            End If
        Next
        .Sheets(1).Delete
        .SaveAs strPath & strFileName
        .Close True
    End With

    ErrExit:
    If Err.Number <> 0 Then MsgBox "Fehler: " & Err.Number & vbLf & vbLf & _
        "Beschreibung: " & Err.Description, vbExclamation, "Fehler"

    GMS True
    Set objWb = Nothing
End Sub

Private Sub GMS(Optional ByVal Modus As Boolean = False)
    Static lngCalc As Long

    With Application
        .ScreenUpdating = Modus
        .EnableEvents = Modus
        .DisplayAlerts = Modus
        .EnableCancelKey = IIf(Modus, 1, 0)
        If Not Modus Then lngCalc = .Calculation
        .Calculation = IIf(Modus, lngCalc, -4135)
        .Cursor = IIf(Modus, -4143, 2)
    End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Unterordner und Arbeitsmappe erstellen

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

45 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Unterordner und Arbeitsmappe erstellen

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

45 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread