Mappen toevoegen in werkboek pad

[Abel Visscher]

Beste,

ik wil graag door middel van een code meerdere mappen toevoegen aan het pad waarin mijn Excel-bestand zich bevindt.
bv. mijn Excel-bestand bevind zich in: C:\Gebruikers\ikke\Mijn documenten\Excel.
WorkBook.path is dan: C:\Gebruikers\ikke\Mijn documenten\Excel

Nu wil ik graag dat doormiddel van 3x een celverwijzing (A1, A2 en A3) drie mappen toevoegen, "HoofdMap" met daarin "Submap1" en daar dan weer in "Submap2"
A1 = Hoofdmap
A2 = Submap1
A3 = Submap2

Ik ben al even aan het puzzelen en zoeken geweest en heb het e.e.a. in elkaar gepuzzeld maar deze code werkt 1 keer en voegt een map toe wat ook logisch is.
Dit is wat ik tot nu toe heb:

Sub PdfMakenEnOpslaanInMap()
Dim Dir As String
Dim BestandsNaam As String
Dir = ActiveWorkbook.Path + "\" & ActiveSheet.Range("A1") & "\"    <== hier moeten nog twee mappen bij.
MkDir ActiveWorkbook.Path + "\" & ActiveSheet.Range("A1") & "\"
BestandsNaam = ActiveSheet.Range("A8").Value
ActiveSheet.Range("B4:D10").ExportAsFixedFormat Type:=xlTypePDF, FileName:=Dir + BestandsNaam, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End Sub

Ik hoop dat iemand mij op weg kan helpen.
Bij voorbaat dank voor reacties.

Groeten Abel

 

[HSV]

Probeer het maar eens.

Sub hsv()
 CreateObject("shell.application").Namespace("C:").newfolder "[COLOR=#3E3E3E]Gebruikers\ikke\Mijn documenten\Excel\[/COLOR]" & Range("A1").Value & "\" & Range("A2").Value & "\" & Range("A3").Value & "\"
End Sub

 

[Abel Visscher]

Beste Harry

Deze code ben ik ook tegen gekomen bij het zoeken en ben daar mee aan het stoeien geweest.
Echter het begin van de map structuur C:\gebruikers\ikke\documenten\excel is geen vast gegeven vandaar de ThisWorkbook.path.
De map waarin het Excel-bestand zich bevind is Excel. daarmee ben ik werkzaam op meerdere pc's op verschillende locaties (niet in netwerk).Als ik nu bv de map Excel op een bureaublad plaats van iemand anders is het pad C:\gebruikers\ikke niet\bureaublad\excel en dan werkt jou code niet.

 

[gast0660]

Probeer

Sub dotchie()
    Dim R As Range
    Dim RootFolder As String
    RootFolder = ThisWorkbook.Path
    For Each R In Range("A1:A3") ' verander
        If Len(R.Text) > 0 Then
            On Error Resume Next
            MkDir RootFolder & "\" & R.Text
            On Error GoTo 0
        End If
    Next R
    End Sub

 

[edmoor]

Of deze, met controle op bestaan van de mappen:

Sub PdfMakenEnOpslaanInMap()
    Dim BestandsNaam As String
    Dim Map As String
    Dim Hfd As String
    Dim i As Byte
    
    Hfd = ActiveWorkbook.Path & "\"
    For i = 1 To 3
        Map = Hfd & "\" & Cells(i, 1).Value
        If Dir(Map, vbDirectory) = "" Then
            MkDir (Map)
        End If
        Hfd = Map & "\"
    Next i
    
    BestandsNaam = ActiveSheet.Range("A8").Value
    ActiveSheet.Range("B4:D10").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Hfd & BestandsNaam, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=True
End Sub

 

[Abel Visscher]

@gast0660

Werkt op zich wel maar deze code maakt 3 mappen aan in excel terwijl een map 'Hoofdmap' met daarin 'supmap1' en daar weer in 'submap2' de bedoeling is.

 

[Abel Visscher]

Beste Edmoor,

Dit is wat ik zocht, ben er blij mee. Ik ga hier verder mee werken.
Iedereen bedankt voor het meedenken en reageren en wellicht tot de volgende keer.

Groeten,
Abel Visscher

 

[edmoor]

Ok. Nog even 2 dingen als advies.

In je originele code gebruik je het woordje dir als variabele. Omdat dat de naam van een bestaande functie binnen VBA is kan je dat beter niet doen. Tevens gebruik je het + teken om strings aan elkaar te plakken. Daar kan je beter het & teken voor gebruiken om datatype problemen te voorkomen.

 

[Abel Visscher]

bedankt voor de tips

Pad ipv Dir is idd beter.

 

[HSV]

Volgens mij was dat niet zo moeilijk om aan te passen.

Sub hsv()
 CreateObject("shell.application").Namespace(ThisWorkbook.Path).newfolder Range("A1").Value & "\" & Range("A2").Value & "\" & Range("A3").Value
End Sub