Link to home
Start Free TrialLog in
Avatar of Tobias B
Tobias BFlag for Germany

asked on

vba code to create folders according to a hyperlink

hello together,

how could i upgrade my existing code witch creates an hyperlink in column B that the code check if the folder is already existing and if not the code will create the folder?

this is the relevant part of my coder to create the hyperlink:

Pfad = "\\C:\Temp\Test\"
     
       
    .....    
    If Sh.Cells(Target.Row, "A") <> "" And Sh.Cells(Target.Row, "D") <> "" And Sh.Cells(Target.Row, "G") <> "" Then
        Sh.Cells(Target.Row, "B") = Sh.Cells(Target.Row, "A")
        Sh.Hyperlinks.Add _
            Anchor:=Sh.Cells(Target.Row, "B"), _
            Address:=Pfad & _
                    Format(Year(Sh.Cells(Target.Row, "G")), "0000") & "_" & _
                    Format(Month(Sh.Cells(Target.Row, "G")), "00") & "_" & _
                    Format(Day(Sh.Cells(Target.Row, "G")), "00") & "\" & _
                    Sh.Cells(Target.Row, "D") & "\" & _
                    Sh.Cells(Target.Row, "A")
                        
    Else
        Sh.Cells(Target.Row, "B") = ""
    End If
    
    Application.EnableEvents = True
End Sub

Open in new window


could someone help me to upgrade the code to create the folders automatically?

thanks in advance.

Tobias
Avatar of Rgonzo1971
Rgonzo1971

Hi,

pls try
YourPath = "c:\tmp\EE\Examples"
If Len(Dir(YourPath, vbDirectory)) = 0 Then
    Shell ("cmd /c mkdir -p """ & YourPath & """")
End If

Open in new window

maybe like this
Pfad = "\\C:\Temp\Test\"
     
       
    If sh.Cells(Target.Row, "A") <> "" And sh.Cells(Target.Row, "D") <> "" And sh.Cells(Target.Row, "G") <> "" Then
        sh.Cells(Target.Row, "B") = sh.Cells(Target.Row, "A")
        VollPfad = Pfad & _
                    Format(sh.Cells(Target.Row, "G"), "yyyy-mm-dd") & "\" & _
                    sh.Cells(Target.Row, "D") & "\"
        If Len(Dir(VollPfad, vbDirectory)) = 0 Then
            Shell ("cmd /c mkdir -p """ & VollPfad & """")
        End If
        sh.Hyperlinks.Add _
            Anchor:=sh.Cells(Target.Row, "B"), _
            Address:=VollPfad & _
                    sh.Cells(Target.Row, "A")
                        
    Else
        sh.Cells(Target.Row, "B") = ""
    End If

Open in new window

EDIT  added CodeRegards
Avatar of Tobias B

ASKER

Hello Rgonzo1971,

thank you for your answer. honestly i didn´t know if i have understand it correctly.

i have taken this:

Pfad = "\\C:\Temp\Test\"
     
       
    If sh.Cells(Target.Row, "A") <> "" And sh.Cells(Target.Row, "D") <> "" And sh.Cells(Target.Row, "G") <> "" Then
        sh.Cells(Target.Row, "B") = sh.Cells(Target.Row, "A")
        VollPfad = Pfad & _
                    Format(sh.Cells(Target.Row, "G"), "yyyy-mm-dd") & "\" & _
                    sh.Cells(Target.Row, "D") & "\"
        If Len(Dir(VollPfad, vbDirectory)) = 0 Then
            Shell ("cmd /c mkdir -p """ & VollPfad & """")
        End If
        sh.Hyperlinks.Add _
            Anchor:=sh.Cells(Target.Row, "B"), _
            Address:=VollPfad & _
                    sh.Cells(Target.Row, "A")
                        
    Else
        sh.Cells(Target.Row, "B") = ""
    End If

Open in new window


but this will not create the Folder. just the Hyperlink is created and nothing else happened.
there was a failure that Vollpfad is not defined and i defined it like this: Dim VollPfad As String

I’m not sure what to do with this:

1:YourPath = "c:\tmp\EE\Examples"
2:If Len(Dir(YourPath, vbDirectory)) = 0 Then
3:    Shell ("cmd /c mkdir -p """ & YourPath & """")
4:End If

Open in new window


thanks
Is VollPfad the path of the hyperlink?

line 6 to 11 create the VollPfad folder(s) if necessary normally
?? VollPfad was a Change from your side ;-)
in my code is Address
You have
Pfad = "\\C:\Temp\Test\"

then
VollPfad = Pfad & _
                    Format(sh.Cells(Target.Row, "G"), "yyyy_mm_dd") & "\" & _
                    sh.Cells(Target.Row, "D") & "\"
that represents the folder to be created is that right?

Pfad = "\\C:\Temp\Test\"
     
       
    If sh.Cells(Target.Row, "A") <> "" And sh.Cells(Target.Row, "D") <> "" And sh.Cells(Target.Row, "G") <> "" Then
        sh.Cells(Target.Row, "B") = sh.Cells(Target.Row, "A")
        VollPfad = Pfad & _
                    Format(sh.Cells(Target.Row, "G"), "yyyy_mm_dd") & "\" & _
                    sh.Cells(Target.Row, "D") & "\"
        If Len(Dir(VollPfad, vbDirectory)) = 0 Then
            Shell ("cmd /c mkdir -p """ & VollPfad & """")
        End If
        sh.Hyperlinks.Add _
            Anchor:=sh.Cells(Target.Row, "B"), _
            Address:=VollPfad & _
                    sh.Cells(Target.Row, "A")
                        
    Else
        sh.Cells(Target.Row, "B") = ""
    End If

Open in new window

Corrected code: underscore in date instead of minus
ok, it Looks like we have some other Problems.

attached you will find the complete code. maybe you got upgrade this code.
i thought i was able to add the changes in my code but obviously I’m doing something wrong.

This code will also create a Protocol of all changes in my list and creates the Hyperlink.
from line 33 it starts with the hyperlink


Option Explicit

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim lngZeile As Long
    Dim NeuerWert As Variant
    Dim AlterWert As Variant
    Dim Pfad As String
    
    Pfad = "\\1000\Vert\Team 1\Au\Test\"
     
    If Sh.Name = "Protokoll" Then Exit Sub
    Application.EnableEvents = False
     
    NeuerWert = Target.Value   ' Neuen Wert merken
    Application.Undo           ' Änderung rückgängig
    AlterWert = Target.Value   ' Alten Wert merken
    Target.Value = NeuerWert   ' Änderung wieder herstellen
     
    With Worksheets("Protokoll")
        .Unprotect
        lngZeile = .Range("A65536").End(xlUp).Row + 1
        .Cells(lngZeile, 1).Value = Application.UserName    'Benutzer
        .Cells(lngZeile, 2).Value = Date    'Datum
        .Cells(lngZeile, 3).Value = Time    'Zeit
        .Cells(lngZeile, 4).Value = Sh.Name 'Blattname, auf dem geändert wurde
        .Cells(lngZeile, 5).Value = Target.Address(0, 0) 'Zelle der Änderung
        .Cells(lngZeile, 6).Value = AlterWert    'alter Eintrag
        .Cells(lngZeile, 7).Value = Target.Value    'neuer Eintrag
        .Cells(lngZeile, 8).Value = Sh.Cells(Target.Row, "A")    'Spalte "A"
        .Protect
    End With
    
    If Sh.Cells(Target.Row, "A") <> "" And Sh.Cells(Target.Row, "D") <> "" And Sh.Cells(Target.Row, "G") <> "" Then
        Sh.Cells(Target.Row, "B") = Sh.Cells(Target.Row, "A")
        Sh.Hyperlinks.Add _
            Anchor:=Sh.Cells(Target.Row, "B"), _
            Address:=Pfad & _
                    Format(Year(Sh.Cells(Target.Row, "G")), "0000") & "_" & _
                    Format(Month(Sh.Cells(Target.Row, "G")), "00") & "_" & _
                    Format(Day(Sh.Cells(Target.Row, "G")), "00") & "\" & _
                    Sh.Cells(Target.Row, "D") & "\" & _
                    Sh.Cells(Target.Row, "A")
                        
    Else
        Sh.Cells(Target.Row, "B") = ""
    End If
    
    Application.EnableEvents = True
End Sub

Open in new window

what is it in Sh.Cells(Target.Row, "A")?
in column "A" is the Name for the "target" Folder

the code creates a Hyperlink with the Information from column G,D and A in the column B
G and D are subfolders
G is a date, but the Folder should have another date Format. thats the reaseon for the "complex" code for column G
ASKER CERTIFIED SOLUTION
Avatar of Rgonzo1971
Rgonzo1971

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
works perfect!! thank you very much for your support.

where was the failure?
I thought the last cell was a file not a folder
so once again thank you for your Support and have a nice Weekend.
Problem was solved. Many thanks to Rgonzo1971