Datei dynamisch in Ordner abspeichern

Sub OrdnerErstellen()
'Library aktivieren Extra Verweise
' MS Scripting Runtime
Dim FSO As New FileSystemObject
Dim pfad As String
Dim strdatei As String
' Pfad zum Desktop
pfad = "C:\Users\Tim\Desktop\"
'Ordner anlegen
FSO.CreateFolder pfad & "\OC" & "-" & Day(Date) & "-" & Month(Date) & "-" & Year(Date)
End Sub

Sub Datei()
Dim strdatei As String
Datei wird geöffnet
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Title = "Bitte Report auswählen"
.InitialFileName = "C:\Users\Tim\Downloads"
.Filters.Add "Arbeitsmappen", "*.xls*", 1
If .Show = -1 Then
strdatei = .SelectedItems(1)
End If
End With
If strdatei  "" Then
Workbooks.Open strdatei
End If
Im dritten Schritt soll die Datei in den zuvor erstellten Ordner abgespeichert werden.
' wird Abgespeichert
Dim SharePath As Variant
'SharePath = ("C:\Users\Tim\Desktop\OC ?")
ActiveWorkbook.SaveAs SharePath & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & "_" & VBA.Format(VBA.Time, "hh-mm-ss") & "_" & "Änderungen"
ActiveWorkbook.Close
Wie bekomme ich es hin das im nächsten Monat die Dateien in den richtigen Ordner abgespeichert werden ? :)
Vielen Dank im voraus :)