Nieuwe directorie maken vanuit geselecteerde cellen.

[peertje2]

Bekijk bijlage 97627

Ik wil de onderstaande macro maken maar helaas lukt het mij niet.
Kan iemand mij helpen?

In bijgaand bestand staan diverse projecten.
Stel dat ik een nieuw project begin op regel 18
Met een druk op een knop zou de macro een directorie moeten kunnen maken van de drie geselecteerde cellen.
De projecten staat standaard in: P:\projecten\
De nieuwe map zou dan: "P:\projecten\Bergambacht\Ammerstol\Project 9" moeten worden.

Hopelijk kan iemand mij helpen

 

[Ginger]

Het MkDir statement gaat je hierbij helpen. Kijk ff in de help van VBA voor een voorbeeldje.

Groet, Leo

 

[HSV]

Zoiets als:

Sub test()
With ActiveWorkbook
    .SaveAs "P:\" & [A18] & "\" & [B18] & "\" & [C18] & ".xlsx"
    .Close
End With
End Sub

Even testen op een testbestandje.
Ps. Directory A18 en B18 moeten al bestaan.

 

[peertje2]

Leo en Harry

Leo,

Ik heb al een poosje zitten zoeken in o.a. dit forum en VBA voorbeelden maar heb helaas niets kunnen vinden op basis van (3) geselecteerde cellen.

Harry,

Een variant op jouw code ben ik al eens tegengekomen maar deze gaat uit van vaststaande cellen.
Nieuwe projecten worden aangemaakt op willekeurige regels en dus niet altijd op rij 18.
Ook is het niet nodig een excelbestand op te slaan in de nieuwe directory.

Bedankt voor jullie snelle reacties.
Groet Peertje2

 

[Warme bakkertje]

Selecteer de cel in kolom A van de regel van welke je een directorystructuur wenst te maken en klik op de knop.

 

[HSV]

Gaaf Rudi.:thumb:

 

[peertje2]

Dat was de oplossing ja.

Ja geweldig warm bakkertje Rudi.
Bedankt

 

[jpvs]

Ook is het niet nodig een excelbestand op te slaan in de nieuwe directory.

Maar wil je dit wel gebruik dan volgende macro:

Private Sub CommandButton1_Click()
    Dim Path As String
    
    rMkDir "C:\Projecten\" & ActiveCell & "\" & ActiveCell.Offset(, 1) & "\" & ActiveCell.Offset(, 2) & "\"
    Path = "C:\Projecten\" & ActiveCell & "\" & ActiveCell.Offset(, 1) & "\" & ActiveCell.Offset(, 2) & "\"
    Application.GetSaveAsFilename (Path)
End Sub

 

[peertje2]

Voor jpvs

Hallo jpvs.

Bedankt voor je reactie.
Mijn probleem was al opgelost maar wilde toch even reageren
Ik krijg op jouw manier de bijgaande melding.
Als leek heb ik geen idee wat dat betekent.

Groet,
Peertje

 

[jpvs]

Je moet dit in een module plaatsen:

Public Sub rMkDir(ByVal mdir As String)
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.GetParentFolderName(mdir) <> "" Then rMkDir FSO.GetParentFolderName(mdir)
On Local Error Resume Next
MkDir mdir
End Sub

Of open het bestand van Warme bakkertje (Directory.xls)
Druk op Alt+F11 en dubbelklik op module1.

 

[peertje2]

Bedankt voorde hulp.

Ik hoop dat ik nog eens aan mag kloppen.