AW: Hier noch eine verbesserte Version
14.07.2015 16:45:03
Michael
Hallo Bernd!
Hier noch eine überarbeitete Version von oben; hier kannst Du den Pfad an dem die Ordner angelegt werden sollen direkt aus einem Dialog wählen (muss also nicht im Makro-Code definiert werden), und der Namensbereich kann variabel lang sein (d.h. es wird das Spaltenende von F:F identifziert), ebenso können nun Leerzeilen vorhanden sein.
Option Explicit
Sub OrdnerStapelanlage()
Dim Info As String
Dim Pfad As String
Dim LeZeile As Long
Dim Namensliste As Range
Dim Name As Range
Dim Ordner As String
Dim i As Integer
'[OPTIONAL] Benutzer-Info und Abbruchsmöglichkeit
Info = MsgBox("Für jeden in Spalte F ab Zeile 2 eingetragenen Namen " & _
"(Zellwert) wird nun ein Ordner in [D:\FLAG] angelegt." & vbCrLf & _
vbCrLf & "Das kann einige Zeit in Anspruch nehmen. Starten?", vbOKCancel, _
"Ordner Stapelanlage starten?")
If Info = vbCancel Then Exit Sub
'Hauptpfad in dem Ordner angelegt werden sollen
Pfad = PfadWahl
'Wenn Namensliste ggf. Leerzeilen enthält
LeZeile = ThisWorkbook.Worksheets("Tabelle1"). _
Cells(ThisWorkbook.Worksheets("Tabelle1").Rows.Count, 6).End(xlUp).Row
'Wo stehen die Ordnernamen
Set Namensliste = ThisWorkbook.Worksheets("Tabelle1").Range("F2:F" & LeZeile)
'Ordner nach Liste anlegen, ggf. "hochzählen"
For Each Name In Namensliste
Select Case Name.Value
Case Is = ""
'Leere Zellen überspringen
Case Else
Ordner = OrdnerSauber(Name.Value)
If Dir(Pfad & "\" & Ordner, vbDirectory) = "" Then
MkDir Pfad & "\" & Ordner
Else:
i = 2
Do Until Dir(Pfad & "\" & Ordner & "_" & i, vbDirectory) = ""
i = i + 1
Loop
MkDir Pfad & "\" & Ordner & "_" & i
End If
End Select
Next
'[OPTIONAL] Benutzer-Info und Hauptpfad nach Stapelanlage öffnen
Info = MsgBox("Ordner wurden angelegt. Verzeichnis wird geöffnet... ", vbInformation, _
"Stapelanlage abgeschlossen!")
Shell "Explorer.exe " & Pfad, vbNormalFocus
End Sub
Function OrdnerSauber(Name As String) As String
'Ordnernamen dürfen nur Buchstaben A-Z inkl. Umlaute enthalten
Dim i As Integer
Dim Klar As String
For i = 1 To Len(Name)
Select Case LCase(Mid(Name, i, 1))
Case Is = "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", _
"n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z", _
Klar = Klar & Mid(Name, i, 1)
Case Else
Klar = Klar
End Select
Next i
OrdnerSauber = Klar
End Function
Function PfadWahl() As String
'Verzeichnis, in das Ordner per Stapelanlage erzeugt werden sollen, über
'Datei-Dialog wählen
Dim SuchDialog As FileDialog
Set SuchDialog = Application.FileDialog(msoFileDialogFolderPicker)
With SuchDialog
.Title = "Bitte Verzeichnis wählen"
.AllowMultiSelect = False
If .Show -1 Then
MsgBox "Vorgang abgebrochen", vbInformation
Exit Function
Else: PfadWahl = .SelectedItems(1)
End If
End With
End Function
Also teste evtl. diesen Code zuerst; Anmerkungen von oben treffen nach wie vor zu.
LG
Michael