AW: Weil ich gerade was Ähnliches gemacht habe..
22.07.2015 14:05:20
Michael
Hallo Tom,
... hier ein Code für Dich. Fehlerüberprüfungen sind nur minimalst eingebaut - ich gehe jetzt davon aus, dass Du in A1:A100 wirklich nur 6-stellige Zahlen stehen hast, die als Ordnernamen gesetzt werden sollen. Kopiere folgenden Code in ein allgemeines Modul einer Arbeitsmappe (Alt + F11 und im VBA-Editor Einfügen... Modul). Die Arbeitsmappe speicherst Du ab (MUSS!) - am Speicherort der Arbeitsmappe werden dann die Ordner angelegt, je nachdem wieviele Einträge Du in A1:A100 machst. In Spalte B finden sich die zugehörigen Hyperlinks.
Sub OrdnerMitHyperlinkAnlegen()
Dim Bereich As Range: Set Bereich = ThisWorkbook.Worksheets("Tabelle1").Range("A1:A100")
Dim Zelle As Range
Dim Pfad As String: Pfad = ThisWorkbook.Path & "\"
Dim Ordner As String
Dim i As Integer
For Each Zelle In Bereich
Select Case Zelle.Value
Case Is = ""
'Leere Zellen überspringen
Case Else
Ordner = OrdnerSauber(Zelle.Value)
If Dir(Pfad & Ordner, vbDirectory) = "" Then
MkDir Pfad & Ordner
Zelle.Offset(0, 1).Hyperlinks.Add _
Anchor:=Zelle.Offset(0, 1), Address:=Pfad & Ordner, _
ScreenTip:="Klicken Sie um zum Ordner zu gelangen", _
TextToDisplay:=Pfad & Ordner
Else:
i = 2
Do Until Dir(Pfad & "\" & Ordner & "_" & i, vbDirectory) = ""
i = i + 1
Loop
MkDir Pfad & Ordner & "_" & i
Zelle.Offset(0, 1).Hyperlinks.Add _
Anchor:=Zelle.Offset(0, 1), Address:=Pfad & Ordner & "_" & i, _
ScreenTip:="Klicken Sie um zum Ordner zu gelangen", _
TextToDisplay:=Pfad & Ordner & "_" & i
End If
End Select
Next
End Sub
Function OrdnerSauber(Name As String) As String
'Ordnernamen um nicht-erlaubte Zeichen bereinigen, hier nur 0-9
Dim i As Integer
Dim Klar As String
For i = 1 To Len(Name)
Select Case LCase(Mid(Name, i, 1))
Case Is = 0, 1, 2, 3, 4, 5, 6, 7, 8, 9
Klar = Klar & Mid(Name, i, 1)
End Select
Next i
OrdnerSauber = Klar
End Function
Läuft?
LG
Michael