Creating folder and subfolders

[Cablek]

I have a script that creates a folder (if non already exists) then saves an excel file in this folder and it works great but a new request had come up where I need to create 2 sub folders with in this new folder... 1 called "drawings" and one called "Obsolete"

this is my present code:


Private Sub CommandButton1_Click()
Dim Pth As String
Dim Filename1 As String
Dim Filename2 As String
Pth = "O:\Customer Drawings" & Range("B3").Value
Filename1 = Range("C3").Value
Filename2 = Range("D3").Value
If Dir(Pth, vbDirectory) = "" Then MkDir (Pth)
ActiveWorkbook.SaveAs Filename:=Pth & "" & Filename1 & "- Rev" & Filename2 & "(" & Format(Date, "dd-mm-yyyy") & ")" & ".xlsm", FileFormat:=52
End Sub


Private Sub Worksheet_change(ByVal Target As Excel.Range)
If Target.Column = 2 And Target.Row >= 3 And Target.Row <= 10000 Then
Target.Offset(0, -1) = Date
End If
End Sub

 

[SpillerBD]

Private Sub CommandButton1_Click()
Dim Pth As String
Dim Filename1 As String
Dim Filename2 As String
    Pth = "C:\Customer Drawings" & Range("B3").Value
    Filename1 = Range("C3").Value
    Filename2 = Range("D3").Value
    If Dir(Pth, vbDirectory) = "" Then
        MkDir (Pth)
        MkDir (Pth & "\Drawings")
        MkDir (Pth & "\Obsolete")
    End If
    ActiveWorkbook.SaveAs Filename:=Pth & "" & Filename1 & "- Rev" & Filename2 & "(" & Format(Date, "dd-mm-yyyy") & ")" & ".xlsm", FileFormat:=52
End Sub