Speicherordner automatisch anlegen

Private Sub CommandButton3_Click()
Sheets("Test_6_bis_9").Visible = True
Sheets("Rechnen").Visible = False
Sheets("Startseite").Visible = False
Dim ArrIndex, iIndex%, sExtension$, iFileFormat%, strFileName$
'Dateinamen aus aktuller Zelle
strFileName = Cells(11, 4).Value
'Ordner da?
If Dir("C:\Testdaten_ET6_bis_6", vbDirectory) = "" Then
MsgBox "Ordner existiert nicht! Bitte einen Ordner mit Name Testdaten_ET6_bis_6 unter  _
Laufwerk C:\ anlegen! Der Ordnername muss genau so wie hier genannt angelegt werden (mit  _
Unterstrichen), also ******Testdaten_ET6_bis_6******", vbCritical
Exit Sub
End If
'Wechselt das aktuelle Laufwerk.
ChDrive "C:"
'Wechselt das aktuelle Verzeichnis oder den aktuellen Ordner
ChDir "C:\Test"
'Datei Version
ArrIndex = Array("xlsx", "xlsm", "xls")
'Extention der Datei
sExtension$ = Right$(strFileName, Len(strFileName) - InStrRev(strFileName, "."))
'Dialog aufrufen
SaveAs "C:\Testdaten_ET6_bis_6\" & strFileName & "_" & "Geburtsdatum" & "_" & Format(Range("K11" _
), "dd_mm_yyyy" _
) & "_" & "Testdatum" & "_" & Format(Range("P11"), "dd_mm_yyyy")
showForm2
Sheets("Startseite").Visible = True
Sheets("Startseite").Activate
Sheets("Startseite").Range("K10").Select
Sheets("Test_6_bis_9").Visible = False
Sheets("Ergebnis_6_bis_9").Visible = False
End Sub