VBA Excel ordner machen lassen

faebi · Jun 10, 2010

Ich habe schon Stunden lang gegoogelt und noch nichts hingekriegt. Ich brauche eine Idiotensichere Lösung

??

Ich muss aus einer Liste mit ca 500 Namen die jeweiligen Ordner erstellen.
Es sieht wie folgt aus:

Code:

<i>
</i>    A
1 Teststrasse_1
2 Pandoraisttoll_4
3 ahastrasse_2
...
518

Hier soll jeweils aus Testrasse_1 der Ordner Teststrasse_1 werden.
Wenn es geht sollten noch unterverzeichnisse erstellt werden, aber das ist zweitklassig.Es wären immer die gleichen Unterverzeichnisse
Der Name Teststrasse wurde aus "teststrasse" und "1" mit excel zusammengestellt.

Wie mache ich das jetzt. Ich brauche eine erklärung von anfang an bis ende. Den code kann ich ja noch einfügen, aber wie starten weiss ich nicht <_<

Morchel · Jun 10, 2010

Hab das mal ganz schnell zusammengrefrickelt.
Daher gibt es auch keine richtige Fehlerprüfung, falls ein Ordner nicht erstellt werden kann (z.B. durch ungültigen Namen). Er wird dann einfach nicht erstellt.

Code:

Sub erstelleOrdner()
Const START_VERZEICHNIS As String = "E:\test1\" 'Startverzeichnis unter dem die neuen Verzeichnisse angelegt werden
Const UNTERVERZEICHNIS As String = "test" 'Name des Unterverzeichnis

Dim sVerzNeu As String
Dim z As Integer

Dim oTabelle As Worksheet
Set oTabelle = Application.ActiveSheet

r = 1
sVerzNeu = Trim(oTabelle.Cells(r, 1))
On Error Resume Next
Do While sVerzNeu <> ""
    MkDir START_VERZEICHNIS & sVerzNeu
    MkDir START_VERZEICHNIS & sVerzNeu & "\" & UNTERVERZEICHNIS
    r = r + 1
    sVerzNeu = Trim(oTabelle.Cells(r, 1))
Loop
On Error GoTo 0
End Sub

VBA Editor öffnen, Code von oben einfügen, Konstanten auf jeweiligen Pfad anpassen.
Unter Spalte A alle Namen auflisten, am besten einmal sortieren, da nach einer leeren Zelle abgebrochen wird.
Makro ausführen klicken (oder ALt + F8 drücken), das Makro "erstelleOrdner" starten und nach kurzer Zeit sollte er durch sein. ; )

faebi · Jun 10, 2010

omg danke danke viel mals. Ich schulde dir was. :juhu:

Noch eine kleine Frage. Du hast das mit dem Unterverzeichnis ja gleich auch gemacht. Wie bekomme ich ein Unterverzeichnis in ein Unterverzeichnis?

Also so: ichdankedirstrasse_20/danke1/danke2/

Und macht das ein Problem wenn mein Ordnername einen Abstand dazwischen hat. Also "danke 2"

edit:

Noch was, macht ein / im Dateiname probleme?
edit2: hat sich geklärt. es macht probleme

Morchel · Jun 10, 2010

faebi said:
Also so: ichdankedirstrasse_20/danke1/danke2/

Dann kannst du einfach unter

Code:

MkDir START_VERZEICHNIS & sVerzNeu & "\" & UNTERVERZEICHNIS

folgende Zeile hinzufügen

Code:

MkDir START_VERZEICHNIS & sVerzNeu & "\" & UNTERVERZEICHNIS & "\Unterunterverzeichnis"

Und macht das ein Problem wenn mein Ordnername einen Abstand dazwischen hat. Also "danke 2"

Nö, kannst ja unter Windows auch ganze normal Ordner und Dateinamen mit Leerzeichen verwenden.

Noch was, macht ein / im Dateiname probleme?
edit2: hat sich geklärt. es macht probleme

jep, "\" und "/" dienen zum Trennen der Verzeichnisse ; )

faebi · Jun 10, 2010

Fehler Mehrfachdeklaration im aktuellen Gültigkeitsbereich

Code:

Sub erstelleOrdner()
Const START_VERZEICHNIS As String = "E:\work\" 'Startverzeichnis unter dem die neuen Verzeichnisse angelegt werden
Const UnterVERZEICHNIS As String = "Admin" 'Name des Unterverzeichnis
Const UnterVERZEICHNIS As String = "Fotos" 'Name des Unterverzeichnis
Const UnterVERZEICHNIS As String = "Site Acquisition Report" 'Name des Unterverzeichnis
Const UnterUnterVERZEICHNIS As String = "Bau" 'Name des Unterverzeichnis
Const UnterUnterVERZEICHNIS As String = "Fotos" 'Name des Unterverzeichnis
Const UnterVERZEICHNIS As String = "Verträge" 'Name des Unterverzeichnis

Dim sVerzNeu As String
Dim z As Integer

Dim oTabelle As Worksheet
Set oTabelle = Application.ActiveSheet

r = 1
sVerzNeu = Trim(oTabelle.Cells(r, 1))
On Error Resume Next
Do While sVerzNeu <> ""
    MkDir START_VERZEICHNIS & sVerzNeu
    MkDir START_VERZEICHNIS & sVerzNeu & "\" & UnterVERZEICHNIS
    MkDir START_VERZEICHNIS & sVerzNeu & "\" & UnterVERZEICHNIS & "\UnterUnterVERZEICHNIS"
    r = r + 1
    sVerzNeu = Trim(oTabelle.Cells(r, 1))
Loop
On Error GoTo 0
End Sub

Ich denke mal das hat etwas mit meinen vielen Const zu tun^^

Morchel · Jun 10, 2010

Ich denke mal das hat etwas mit meinen vielen Const zu tun^^

Ja, eine Konstante (Const) darf nur einmal vorkommen.

Code:

Sub erstelleOrdner()
Const START_VERZEICHNIS As String = "E:\work\" 'Startverzeichnis unter dem die neuen Verzeichnisse angelegt werden
Const UnterVERZEICHNIS1 As String = "Admin" 'Name des Unterverzeichnis
Const UnterVERZEICHNIS2 As String = "Fotos" 'Name des Unterverzeichnis
Const UnterVERZEICHNIS3 As String = "Site Acquisition Report" 'Name des Unterverzeichnis
Const UnterVERZEICHNIS4 As String = "Verträge" 'Name des Unterverzeichnis

Const UnterUnterVERZEICHNIS1 As String = "Bau" 'Name des Unterverzeichnis
Const UnterUnterVERZEICHNIS2 As String = "Fotos" 'Name des Unterverzeichnis


Dim sVerzNeu As String
Dim z As Integer

Dim oTabelle As Worksheet
Set oTabelle = Application.ActiveSheet

r = 1
sVerzNeu = Trim(oTabelle.Cells(r, 1))
On Error Resume Next
Do While sVerzNeu <> ""
    MkDir START_VERZEICHNIS & sVerzNeu
    MkDir START_VERZEICHNIS & sVerzNeu & "\" & UnterVERZEICHNIS1
    MkDir START_VERZEICHNIS & sVerzNeu & "\" & UnterVERZEICHNIS1 & "\" & UnterUnterVERZEICHNIS1
    r = r + 1
    sVerzNeu = Trim(oTabelle.Cells(r, 1))
Loop
On Error GoTo 0
End Sub

Kannst aber im Prinzip auch ohne die Konstanten arbeiten.

Code:

<i>
</i>MkDir START_VERZEICHNIS & "Verträge"
MkDir START_VERZEICHNIS & "Verträge\Fotos"
MkDir START_VERZEICHNIS & "Verträge\Bau"
MkDir START_VERZEICHNIS & "Admin"
MkDir START_VERZEICHNIS & "Admin\Fotos"

faebi · Jun 10, 2010

Irgendwie geht das nicht.
Soory kannst du mir nochmal helfen?

es sollte eigentlich so aussehen

Code:

<i>
</i>strasse_1/Admin
             /Fotos
            /Site Acquisition Report
                 /Bau
                 /Eigentümer
            /Verträge

Das gleiche bei Strasse 2 usw...

Morchel · Jun 10, 2010

Code:

Sub erstelleOrdner()
Const START_VERZEICHNIS As String = "E:\work\" 'Startverzeichnis unter dem die neuen Verzeichnisse angelegt werden

Dim sVerzNeu As String
Dim z As Integer

Dim oTabelle As Worksheet
Set oTabelle = Application.ActiveSheet

r = 1
sVerzNeu = Trim(oTabelle.Cells(r, 1))
On Error Resume Next
Do While sVerzNeu <> ""
    MkDir START_VERZEICHNIS & sVerzNeu
    MkDir START_VERZEICHNIS & sVerzNeu & "\Admin"
    MkDir START_VERZEICHNIS & sVerzNeu & "\Admin\Fotos"
    MkDir START_VERZEICHNIS & sVerzNeu & "\Admin\Site Acquisition Report"
    MkDir START_VERZEICHNIS & sVerzNeu & "\Admin\Site Acquisition Report\Bau"
    MkDir START_VERZEICHNIS & sVerzNeu & "\Admin\Site Acquisition Report\Eigentümer"
    MkDir START_VERZEICHNIS & sVerzNeu & "\Admin\Verträge"
    r = r + 1
    sVerzNeu = Trim(oTabelle.Cells(r, 1))
Loop
On Error GoTo 0
End Sub

So, jetzt aber.
Mein letzter Beitrag enthielt auch ein Bisschen Pfusch

faebi · Jun 10, 2010

ahh verdammt, meiner enthielt auch pfusch <_<
Kein wunder stimmt es nie. Der Browser hat es falsch angezeigt X-(

Code:

<i>
</i>strasse_1   /Admin
            /Fotos
            /Site Acquisition Report
                 /Bau
                 /Eigentümer
            /Verträge

Jetzt stimmt es. Sorry wirklich.

edit:
Ist ja einfach. Vorher ging es aber irgendwie nicht.

Code:

Sub erstelleOrdner()
Const START_VERZEICHNIS As String = "E:\work\" 'Startverzeichnis unter dem die neuen Verzeichnisse angelegt werden

Dim sVerzNeu As String
Dim z As Integer

Dim oTabelle As Worksheet
Set oTabelle = Application.ActiveSheet

r = 1
sVerzNeu = Trim(oTabelle.Cells(r, 1))
On Error Resume Next
Do While sVerzNeu <> ""
    MkDir START_VERZEICHNIS & sVerzNeu
    MkDir START_VERZEICHNIS & sVerzNeu & "\Admin"
    MkDir START_VERZEICHNIS & sVerzNeu & "\Fotos"
    MkDir START_VERZEICHNIS & sVerzNeu & "\Site Acquisition Report"
    MkDir START_VERZEICHNIS & sVerzNeu & "\Site Acquisition Report\Bau"
    MkDir START_VERZEICHNIS & sVerzNeu & "\Site Acquisition Report\Eigentümer"
    MkDir START_VERZEICHNIS & sVerzNeu & "\Verträge"
    r = r + 1
    sVerzNeu = Trim(oTabelle.Cells(r, 1))
Loop
On Error GoTo 0
End Sub

Danke viel mals, du hast mir viele Stunden nervtötende arbeit erspart und mir einen guten einstieg in VBA gegeben ^_^

VBA Excel ordner machen lassen

faebi

Member

Morchel

Member

faebi

Member

Morchel

Member

faebi

Member

Morchel

Member

faebi

Member

Morchel

Member

faebi

Member

Similar threads