VBA create subFolder

I'm a novice and I need some help.
In this existing VBA code I have to add a subfolder in which to store the files.
The subfolder should be = Range ("B 5") .Value
The ready VBA code below creates a folder if it does not exist and stores the files in it, but I need a subfolder called Range ("B5") .Value.

I please for your help

Public Sub SaveToDir()

Dim strDocs As String
Dim strSubFilder As String
Dim strNamePID As String

CDir = CreateObject("WScript.Shell").SpecialFolders("A5")


SaveDir = "\\virgo\work\CustomerService\BusinessRecalculation\DI_KI_02.04.2012_2013\" & ActiveSheet.Range("A5")

If Len(Dir(SaveDir, vbDirectory)) = 0 Then
   MkDir SaveDir
End If


LDate = Date


SaveName = "Work" & "_" & ActiveSheet.Range("B5") & "_" & LDate & "_" & Hour(Now) & Minute(Now) & Second(Now) & ".xlsm"

If Len(Dir(SaveDir & "\" & SaveName, vbDirectory)) > 0 Then
    Resp = MsgBox("File name:   " & SaveName & vbCrLf & vbCrLf & "already exists in:  " & vbCrLf & vbCrLf & SaveDir & vbCrLf & vbCrLf & "Press Okay to continue, Cancel to abort", vbOKCancel)
End If
'

If Resp = vbCancel Then
    Exit Sub
End If

Application.DisplayAlerts = False

strSubFilder = Range("B5").Value

strNamePID = Range("A5").Value

    MkDir strDocs & "\" & strSubFilder

    SaveDir = strDocs & "\" & strSubFilder & "\" & strFileName
   
    MkDir strSaveDir


ActiveWorkbook.SaveCopyAs "\\virgo\work\CustomerService\BusinessRecalculation\DI_KI_02.04.2012_2013\" & ActiveSheet.Range("A5") & "\" & strSubFilder & "\" & SaveName

CurrentFile = "\\virgo\work\CustomerService\BusinessRecalculation\DI_KI_02.04.2012_2013\" & ActiveSheet.Range("A5") & "\" & strSubFilder & "\" & SaveName

MsgBox ("File name:   " & SaveName & vbCrLf & vbCrLf & "has been saved to  " & vbCrLf & vbCrLf & SaveDir)

Workbooks.Open CurrentFile
       


       
999   End Sub