Hyperlin nach Liste

[Andyle]

Ich erstelle Ordner und Hyperlinks nach einer Spalte .Range("L6:L200")

Wie kann ich jetzt die Hyperlinks nicht in .Range("L6:L200") sondern in .Range("R6:R200") erstellen lassen.

Bsp.: Hyperlink .Range("R6") erstellen wenn .Range("L6") Wert hat.

Code:

'Ordner und Hyperlinks nach Liste anlegen
Sub OrdnerUndLinksNachListe()

    Dim Ws As Worksheet
    Dim Liste As Range
    Dim Unterordner As Range
    Dim Pfad As String
   
    Application.ScreenUpdating = False
   
    Set Ws = ThisWorkbook.Worksheets("Prüfungen")
    With Ws
        Set Liste = .Range("L6:L200")
        For Each Unterordner In Liste.SpecialCells(xlCellTypeConstants)
            ErstelleOrdner (ThisWorkbook.Path & "/" & Unterordner & "/")
            Unterordner.Hyperlinks.Add _
                anchor:=Unterordner, Address:=ThisWorkbook.Path & "/" & Unterordner & "/", _
                ScreenTip:="Klicken um Ordner zu öffnen", _
                TextToDisplay:="" & Unterordner & ""
        Next Unterordner
    End With
   
    Application.ScreenUpdating = True
   
End Sub

'Neuen Ordner anlegen, wenn noch nicht vorhanden
Sub ErstelleOrdner(Pfad As String)
    If OrdnerExistiert(Pfad) = False Then
        MkDir Pfad
    End If
End Sub

'Prüfen ob Ordner schon vorhanden
Function OrdnerExistiert(Pfad As String) As Boolean
    If Dir(Pfad, vbDirectory) = "" Then
        OrdnerExistiert = False
    Else
        OrdnerExistiert = True
    End If
End Function

[snb]

Code:

Range("L6:L200").copy Range("R6")

[Kuwer]

Hallo,

ersetze

            Unterordner.Hyperlinks.Add _

durch

            Unterordner.Offset(,6).Hyperlinks.Add _

Gru0, Uwe

[Andyle]

Vielen Dank für den Hinweis!

War noch etwas mehr antupassen, da es so nicht funktionierte.

Angepasster Code:

Code:

'Ordner und Hyperlinks nach Liste anlegen
Sub OrdnerUndLinksNachListe()

    Dim Ws As Worksheet
    Dim Liste As Range
    Dim Unterordner As Range
    Dim Pfad As String
   
    Application.ScreenUpdating = False
   
    Set Ws = ThisWorkbook.Worksheets("Prüfungen")
    With Ws
        Set Liste = .Range("L6:L200")
        For Each Unterordner In Liste.SpecialCells(xlCellTypeConstants)
            ErstelleOrdner (ThisWorkbook.Path & "/" & Unterordner & "/")
            Unterordner.Offset(, 6).Hyperlinks.Add _
                anchor:=Unterordner.Offset(, 6), Address:=ThisWorkbook.Path & "/" & Unterordner & "/", _
                ScreenTip:="Klicken um Ordner " & """" & Unterordner & """" & " zu öffnen", _
                TextToDisplay:="Ordner " & """" & Unterordner & """" & " öffnen"
            Unterordner.Offset(, 6).Font.ColorIndex = 3
        Next Unterordner
    End With

    MsgBox "Ordner wurden erstellt!", vbInformation, "Ordnererstellung"
    Application.ScreenUpdating = True
   
End Sub

Hab jetzt das automatische ausfühen eingefügt.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.Intersect(Target, Sheets("Prüfungen").Range("L6:L200")) Is Nothing Then
Call OrdnerUndLinksNachListe
End If
End Sub

Nur wie bekomme in in Spalte R die Einträge  gelöscht wenn ich in Spalte L lösche?

[Andyle]

Hat sich erledigt!

Code:

Code:

'Ordner und Hyperlinks nach Liste anlegen
Sub OrdnerUndLinksNachListe()

ActiveSheet.Unprotect

    Dim Ws As Worksheet
    Dim Liste As Range
    Dim Unterordner As Range
    Dim Pfad As String
   
    Application.ScreenUpdating = False
   
    If ActiveCell.Value <> "" Then
   
    Set Ws = ThisWorkbook.Worksheets("Prüfungen")
    With Ws
        Set Liste = .Range("L6:L200")
        For Each Unterordner In Liste.SpecialCells(xlCellTypeConstants)
            ErstelleOrdner (ThisWorkbook.Path & "/" & Unterordner & "/")
               
            Unterordner.Offset(, 6).Hyperlinks.Add _
                anchor:=Unterordner.Offset(, 6), Address:=ThisWorkbook.Path & "/" & Unterordner & "/", _
                ScreenTip:="Klicken um Ordner " & """" & Unterordner & """" & " zu öffnen", _
                TextToDisplay:="Ordner " & """" & Unterordner & """" & " öffnen"
            Unterordner.Offset(, 6).Font.ColorIndex = 3
           
        Next Unterordner
    End With
   
            Else
            ActiveCell.Offset(, 6).ClearContents
            End If

    Application.ScreenUpdating = True
   
    MsgBox "Ordner wurden erstellt!", vbInformation, "Ordnererstellung"
   
    ActiveSheet.Protect
   
End Sub

---

Gibt es eventuell eine Möglichkeit der Ordnerüberwachung?
In Range("L6:L200") stehen alle zu erstellenden Ordner als Text.

Diese werden ja auch erstellt.

Bei der Makroausführung soll er schauen, ob nur alle in Range("L6:L200") Ordner existieren.

Gibt es einen weiteren "unbekannten" Ordner der nicht in Range("L6:L200") steht soll er schauen, ob Dateien drin sind.
Wenn nicht dann Ordner löschen wenn er nicht in Range("L6:L200") aufgelistet ist.

[Gast 123]

Hallo

mit dieser Beispieldatei kannst du alle Ordner auflisten. Umgemodelt auf Ordner mit Inhalten.
Das Makro kannst du ja auf deinen Bereich ab L6:L200 selbst umschreiben.  Viel Spass.

mfg Gast 123

[Andyle]

Ich möchte ja Die ordner bzw. Dateien nicht auflisten.

Es sollen lediglich die ordner erstellt werden, die in L6:L200 stehen.

Wenn da was gelöscht wird, soll er auch den ordner löschen, wenn dieser in L6:L200 nicht mehr vorkommt, außer er hat bereits
Dateien als Inhalt.

[Gast 123]

Hallo

Sorry, Aufgabe offenbar falsch verstanden.  Dann feiert schönen Karneval ...

mfg Gast 123

[Andyle]

So, mein bisheriger Code.

Nur wie lösche ich jetzt die Ordner, die leer sind und nicht in L6:L200 stehen?

Code:

'Ordner und Hyperlinks nach Liste anlegen
Sub OrdnerUndLinksNachListe()

ActiveSheet.Unprotect

    Application.ScreenUpdating = False

    Dim Ws As Worksheet
    Dim Liste As Range
    Dim Unterordner As Range
    Dim pfad As String
    Dim strDir As String
   
    Dim strOrdnerName As String
    Dim strOrdnerExistiert As String
   
    If ActiveCell.Value <> "" Then
   
    Set Ws = ThisWorkbook.Worksheets("Prüfungen")
    With Ws
        Set Liste = .Range("L6:L200")
        For Each Unterordner In Liste.SpecialCells(xlCellTypeConstants)
       
            ErstelleOrdner (ThisWorkbook.Path & "/" & Unterordner & "/")
               
            Unterordner.Offset(, 6).Hyperlinks.Add _
                anchor:=Unterordner.Offset(, 6), Address:=ThisWorkbook.Path & "/" & Unterordner & "/", _
                ScreenTip:="Klicken um Ordner " & """" & Unterordner & """" & " zu öffnen", _
                TextToDisplay:="Ordner " & """" & Unterordner & """" & " öffnen"
            Unterordner.Offset(, 6).Font.ColorIndex = 3
       
    ' Löschebene
   
    'Feststellen, ob Verzeichnis existiert
    strOrdnerName = ThisWorkbook.Path & "\" & Unterordner & "\"
    strOrdnerExistiert = Dir(strOrdnerName, vbDirectory)

    If strOrdnerExistiert <> "" Then
       
        'Feststellen, ob eine Datei in einem Verzeichnis existiert
        If Len(Dir(ThisWorkbook.Path & "/" & Unterordner & "/*.*")) = 0 Then
       
   
    On Error Resume Next
   ' Ordner löschen
   RmDir strOrdnerName ' Ordner löschen
   On Error GoTo 0
       
       
        Else
        MsgBox "Das Verzeichnis " & """" & Unterordner & """" & " enthält Dateien und kann nicht gelöscht werden!"
        End If
   
   
    Else
        MsgBox "Der ausgewählte Ordner " & Unterordner & " existiert nicht!"
    End If
       
        Next Unterordner
    End With
   
            Else
            ActiveCell.Offset(, 6).ClearContents
            End If
           
    Application.ScreenUpdating = True
   
    MsgBox "Ordner wurden erstellt, Ordnerlink wurde aktualisiert!", vbInformation, "Ordnererstellung"
   
    ActiveSheet.Protect
   
End Sub