Aanmaken mappen vanuit Excel

[wiki]

Met dank aan een ander thread in het forum weet ik hoe ik vanuit excel word documenten aan kan maken. Met welke wijziging kan ik dat ook gebruiken voor het aanmaken van mappen?

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And ActiveSheet.UsedRange.Rows.Count = Target.Row Then
    Dim Wrd As Object
    ScreenUpdating = False
    Bestandsnaam = "d:\" & Cells(Target.Row, 1) & ".doc"
    Set Wrd = CreateObject("Word.Application")
    
    Wrd.Visible = False
    If Dir(Bestandsnaam) <> "" Then
        Response = MsgBox("Bestand overschrijven?", vbYesNo + vbCritical + vbDefaultButton2)
        If Response = vbYes Then
            Wrd.Documents.Add
            Wrd.ActiveDocument.SaveAs Bestandsnaam
            Wrd.Quit
            Set Wrd = Nothing
        End If
    Else
        Wrd.Documents.Add
        Wrd.ActiveDocument.SaveAs Bestandsnaam
        Wrd.Quit
        Set Wrd = Nothing
    End If

    Cells(Target.Row, 2) = "1"
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, 2), Address:=Bestandsnaam
    Cells(Target.Row, 2).Font.Name = "Wingdings"
    ScreenUpdating = True
End If
   
End Sub

 

[Wigi]

Dan moet je MkDir gebruiken.

Let wel dat je maar 1 map per keer kan aanmaken, m.a.w. alle bovenliggende mappen (parents als je wil) moeten bestaan vooraleer daarin een volgende map kan gemaakt worden.

Wigi

 

[wiki]

Bedank wigi

 

[wiki]

Beste Wigi,

Ik weet niet hoe ik dit aan moet passen in VBA. Het volgende heb ik geprobeerd

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And ActiveSheet.UsedRange.Rows.Count = Target.Row Then

    ScreenUpdating = False
    Bestandsnaam = "d:\" & Cells(Target.Row, 1 
Mkdir. SaveAs Bestandsnaam
    End If

    Cells(Target.Row, 2) = "1"
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, 2), Address:=Bestandsnaam
    Cells(Target.Row, 2).Font.Name = "Wingdings"
    ScreenUpdating = True
End If
   
End Sub

 

[snb]

Suggestie:

maak een leeg Word-bestand.
Sla dat op als "D:\test.doc"

als in de cellen het volledige pad en de bestandsnaam staan, maak je lege wordbestanden op basis van je spreadsheet met 1 regel code:

Private Sub Worksheet_Change(ByVal Target As Range) 
  If Target.Column = 1 And ActiveSheet.UsedRange.Rows.Count = Target.Row Then filecopy "D:\test.doc", Target & ".doc"
End Sub

Als je wil testen of de map voor dat nieuwe bestand bestaat kan dat met:

Private Sub Worksheet_Change(ByVal Target As Range) 
  If Target.Column = 1 And ActiveSheet.UsedRange.Rows.Count = Target.Row Then
    sq=split(target,"\")
    c0=sq(0) & "\" & sq(1)
    for j= 1 to ubound(sq)-1
      if dir(c0,16)="" then mkdir c0
      c0=c0 & "\" & sq(j)
    next
    filecopy "D:\test.doc", Target & ".doc"
  End If   
End Sub

Wat mij betreft mag de draad waar jij je oorspronkelijke code vandaan had aangepast worden (want onnodig ingewikkeld en traag).

 

[wiki]

De eerste stap is gelukt door op mkdir te zoeken, maar de hyperlink werkt nog niet

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And ActiveSheet.UsedRange.Rows.Count = Target.Row Then
  
    ScreenUpdating = False
    dirnaam = "d:\" & Cells(Target.Row, 1)
   
    MkDir "d:\ " & Cells(Target.Row, 1)
    

    Cells(Target.Row, 2) = "1"
    ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, 2), Address:=dirnaam
    Cells(Target.Row, 2).Font.Name = "Wingdings"
    ScreenUpdating = True
End If
   
End Sub