Automatisch Ordner erstellen mit Zellenname

[Unwissender]

Hallo liebe Clever-Excel-Forum-Community,

ich konnte leider nirgends eine Lösung für mein Problem finden, deshalb die Frage:

Ich pflege eine To-Do-Liste. In der A-Spalte befindet sich ein Hyperlink, welcher zu einer Ergebnisablage führt.

Bisher muss ich in diese Spalte immer beispielsweise "2019_09_09" eintragen, einen Ordner mit gleichem Namen auf der Festplatte erstellen und am Schluss noch einen Hyperlink erstellen.

Dieses Prozedere möchte ich automatisieren.

Sprich: Ich gebe in Spalte A beispielsweise "2019_05_18" ein. Dann soll automatisch ein Ordner mit gleichem Namen erstellt werden und ein Hyperlink zu diesem Ordner hin erstellt werden.


Vielen Dank für eure Hilfe!


Schöne Grüße
Unwissender

[Case]

Hallo, :19:

kopiere folgenden Code in den Codebereich des Tabellenblattes in welchem du Daten eingibst: :21:

Code:

Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Const strPath As String = "C:\Temp\" ' ANPASSEN!!!!!!
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Columns(1)) Is Nothing And Target.CountLarge = 1 Then
        MakeSureDirectoryPathExists strPath & Target.Value & "\"
        Hyperlinks.Add Anchor:=Target, Address:=strPath & Target.Value, TextToDisplay:=Target.Value
    End If
End Sub

Pfad anpassen. Fertig. :21:

[Unwissender]

Hallo Case,

ich bin jedesmal begeistert von der schnellen und zielgerichteten Hilfe hier! :)

Vielen Dank soweit, der Ordner wird erstellt und ein Hyperlink wird generiert.
Ich habe aber noch ein Problemchen:

Ich verwende bereits einen Code (automatisches Verschieben von Zeilen in ein anderes Blatt) und weiß nicht, wie ich deinen zweiten Code dort ,,integrieren" soll.
Ich kopiere dir den bisherigen Code einmal unten hinein.

Ich freue mich auf deine Antwort!


Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lngErste As Long
    If Target.Column = 2 Then
        If Target.Count = 1 Then
            If UCase(Target) = "JA" Then
                With Worksheets("Erledigt")
                    lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                        .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
                    Target.EntireRow.Copy .Cells(lngErste, 1)
                    Target.EntireRow.Delete
                End With
           
            ElseIf UCase(Target) = "WV" Then
                With Worksheets("Wiedervorlage")
                    lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                        .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
                    Target.EntireRow.Copy .Cells(lngErste, 1)
                    Target.EntireRow.Delete
                End With
            End If
        End If
    End If
End Sub

[Case]

Hallo, :19:

der komplette Code dann so: :21:

Code:

Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As Long
Const strPath As String = "C:\Temp\" ' ANPASSEN!!!!!!
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lngErste As Long
    If Target.Column = 2 Then
        If Target.Count = 1 Then
            If UCase(Target) = "JA" Then
                With Worksheets("Erledigt")
                    lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                        .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
                    Target.EntireRow.Copy .Cells(lngErste, 1)
                    Target.EntireRow.Delete
                End With
            ElseIf UCase(Target) = "WV" Then
                With Worksheets("Wiedervorlage")
                    lngErste = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                        .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count) + 1
                    Target.EntireRow.Copy .Cells(lngErste, 1)
                    Target.EntireRow.Delete
                End With
            End If
        End If
    ElseIf Not Intersect(Target, Columns(1)) Is Nothing And Target.CountLarge = 1 Then
        MakeSureDirectoryPathExists strPath & Target.Value & "\"
        Hyperlinks.Add Anchor:=Target, Address:=strPath & Target.Value, TextToDisplay:=Target.Value
    End If
End Sub

[snb]

Oder:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column & Target.Count <> 21 Or Target.Value = "" Then Exit Sub
    
    Select Case UCase(Target)
    Case "JA"
        Target.EntireRow.Cut Sheets("Erledigt").Cells(Rows.Count, 1).End(xlUp).Offset(1).EntireRow
    Case "WV"
        Target.EntireRow.Cut Sheets("Wiedervorlage").Cells(Rows.Count, 1).End(xlUp).Offset(1).EntireRow
    Case Else
        c00 = "G:\OF\" & Target
        If Dir(c00) = "" Then MkDir c00
        Hyperlinks.Add Target, c00, Target.Value
    End Select
End Sub

[Unwissender]

Vielen vielen Dank Case und snb!
Funktioniert alles einwandfrei :18: