Организация склада, макрос регистрации поступления пробы

Sub Сохранение()
       Dim год As String
        Dim Месяц As String
        Dim день As String
        Dim Fold As String
        Dim s As String
        Dim Pod As String
        Dim FileNameX As String
        Dim FileNameXls As String
        Dim strPath As String
Path = "G:\ЦССС\ArhiveNew"  'папка с вложениями
Coren = "G:\ЦССС\ArhiveNew"  'корневая папка
     Месяц = Sheets("2см").Range("BQ3").Value            'месяц
     день = Format(Sheets("1см").Range("A4").Value, "dd") 'день
     год = Sheets("2см").Range("BO2").Value              'год
     Fold = Path + год                                   'папка год
     Pod = Fold + "" + Месяц                            'папка месяц
     FileNameX = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & "  " & день & "  " & Месяц & "  " & год & ".xlsm" 'имя файла
     strPath = Pod & "" & FileNameX
     FileNameXls = strPath
        'Проверка корневой папки, если есть то сохраняем
If Dir(Path, vbDirectory) <> "" Then
      On Error Resume Next
      s = GetAttr(strPath) And 0
             ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
    Else
      MkDir Path:=Coren 'создание корневой папки с вложенной папкой год, месяц + сохранение файла
      MkDir Path:=Fold
      MkDir Path:=Pod
      On Error Resume Next
      s = GetAttr(strPath) And 0
             ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
End If
        'Если есть папка с именем года сохраняем
If Dir(Fold, vbDirectory) <> "" Then
      On Error Resume Next
      s = GetAttr(strPath) And 0
             ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
    Else
      MkDir Path:=Fold  'создание папки с именем года + сохранение
      On Error Resume Next
      s = GetAttr(strPath) And 0
             ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
 End If
        'если есть папка с именем месяца, то сохраняем
If Dir(Pod, vbDirectory) <> "" Then
      On Error Resume Next
      s = GetAttr(strPath) And 0
             ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
    Else
      MkDir Path:=Pod   'создание папки с именем месяца + сохранение
      On Error Resume Next
      s = GetAttr(strPath) And 0
             ActiveWorkbook.SaveCopyAs Filename:=FileNameXls
 End If
End Sub