Почему создаются мои папки / подпрограммы, но мой файл не помещается в правильную папку?

Question

У меня создаются папки и подпапки, но файлы, которые сохраняются по этому пути, не являются правильными файлами.Что-то мне нужно изменить в строке wb.SaveCopyAs?

        Last = Data(i, 1)
        Mgr = Data(i, 2)

        strNewPath = BASEPATH & Mgr & "\"
        If Len(Dir(strNewPath, vbDirectory)) = 0 Then
            MkDir strNewPath
        End If


        strNewPath = strNewPath & Last & "\"
        If Len(Dir(strNewPath, vbDirectory)) = 0 Then
            MkDir strNewPath
        End If

Это блоки кода, которые сохраняют файл в папке, но когда я открываю папку сотрудника Last, в нем появляется неправильная оценка.

Вот остаток кода:

Option Explicit

Sub Main()
  Dim wb As Workbook
  Dim Data, Last, Mgr
  Dim i As Long, j As Long, k As Long, a As Long
  Dim Dest As Range
  Dim BASEPATH As String, strNewPath As String

  BASEPATH = "C:\Users\cuts\"

  Set wb = Workbooks("CIB_Assessment_Template.xlsx")

  Set Dest = wb.Sheets("Assessment Results").Range("B2")

  With ThisWorkbook.Sheets("Sheet1")
    Data = .Range("S2", .Range("A" & Rows.Count).End(xlUp))
  End With
  wb.Activate
  Application.ScreenUpdating = False

  For i = 1 To UBound(Data)

    If Data(i, 1) <> Last Then

      If i > 1 Then

        Dest.Select

            Last = Data(i, 1)
            Mgr = Data(i, 2)

            strNewPath = BASEPATH & Mgr & "\"
            If Len(Dir(strNewPath, vbDirectory)) = 0 Then
                MkDir strNewPath
            End If


            strNewPath = strNewPath & Last & "\"
            If Len(Dir(strNewPath, vbDirectory)) = 0 Then
                MkDir strNewPath
            End If


        wb.SaveCopyAs strNewPath & _
          "CIB_Assessment.xlsx"
      End If
      Dest.Resize(, Columns.Count - Dest.Column).EntireColumn.ClearContents
      Last = Data(i, 1)
      Mgr = Data(i, 2)
      j = 0
    End If

    a = 0
    For k = 1 To UBound(Data, 2)
      Dest.Offset(a, j) = Data(i, k)
      a = a + 1
    Next
    j = j + 1
  Next

   SaveCopy wb, Last, Mgr '<< save the last report


End Sub