Clever-Excel-Forum - Automatisch Ordner erstellen mit Zellenname

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

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:

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! Sleepy

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

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

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

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