VBA Excel ordner machen lassen


faebi

Member
Joined
Mar 23, 2010
Messages
199
Location
SG Schweiz
LOCATION
SG Schweiz
Ich habe schon Stunden lang gegoogelt und noch nichts hingekriegt. Ich brauche eine Idiotensichere Lösung :confused:??

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 <_<
 
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. ; )
 
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 :)
 
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 ; )
 
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^^
 
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"
 
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...
 
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 :D
 
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 ^_^
 
Back
Top