Move current file to another folder based on drop list selected

Move ThisWorkbook

• The code needs to be copied to the sheet module (e.g. Sheet1) of the worksheet containing the dropdowns.

Basic

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const sAddress As String = "E8"
    Const dInitialPath As String = "C:\"
    
    Dim sCell As Range: Set sCell = Intersect(Me.Range(sAddress), Target)
    If sCell Is Nothing Then Exit Sub
    
    Dim swb As Workbook: Set swb = Me.Parent
    
    Dim dSubFolderName As String: dSubFolderName = CStr(sCell.Value)
    
    Select Case dSubFolderName
    Case "Dest", "Other"
        Dim sFilePath As String: sFilePath = swb.FullName
        Dim dFilePath As String
        dFilePath = dInitialPath & dSubFolderName & "\" & swb.Name
        If StrComp(sFilePath, dFilePath, vbTextCompare) <> 0 Then
            Application.DisplayAlerts = False ' overwrite without confirmation
                swb.SaveAs dFilePath
            Application.DisplayAlerts = True
            Kill sFilePath
            MsgBox "The new filepath is '" & dFilePath & "'.", _
                vbInformation
        Else
            MsgBox "You are trying to move this file to the same location.", _
                vbExclamation
            Exit Sub
        End If
    End Select
    
End Sub

Improved

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    MoveThisWorkbook Target
End Sub

Sub MoveThisWorkbook(ByVal Target As Range)
    Const ProcName As String = "MoveThisWorkbook"
    
    ' Define constants.
    ' Source
    Const sAddress As String = "E8"
    ' Destination
    Const dInitialPath As String = "C:\"
    Const dSubFoldersList As String = "Dest,Other"
    ' If you modify one of the following two (e.g. '".xlsb"'),
    ' you need to modify the other accordingly (e.g. 'xlExcel12').
    Const dNotSavedFileExtension As String = ".xlsm"
    Const dNotSavedFileFormat As Long = xlOpenXMLWorkbookMacroEnabled
    ' Booleans
    Const InformWhenMoved As Boolean = True
    Const ExploreNewLocation As Boolean = True
    
    ' Reference the source worksheet ('sws').
    Dim sws As Worksheet: Set sws = Target.Worksheet
    
    ' Reference the source (dropdown) cell ('sCell').
    Dim sCell As Range: Set sCell = Intersect(sws.Range(sAddress), Target)
    If sCell Is Nothing Then Exit Sub
    
    ' Return the subfolders from the list ('dSubFoldersList')
    ' in the destination subfolders array ('dSubFolders').
    Dim dSubFolders() As String: dSubFolders = Split(dSubFoldersList, ",")
    
    ' Write the dropdown subfolder, the string representation of the value
    ' in the source cell, to a variable ('dSubFolder').
    Dim dSubFolder As String: dSubFolder = CStr(sCell.Value)
    
    ' Check if the dropdown subfolder is not contained
    ' in the destination subfolders array.
    If IsError(Application.Match(dSubFolder, dSubFolders, 0)) Then
        MsgBox "'" & dSubFolder & "' is not contained in the following list:" _
            & vbLf & Join(dSubFolders, vbLf), vbExclamation, ProcName
        Exit Sub
    End If
    
    ' Write the (application) path separator to a variable ('APS').
    Dim APS As String: APS = Application.PathSeparator
    
    ' Append a path separator to the initial destination
    ' folder path, if it doesn't end with one already.
    Dim diPath As String: diPath = dInitialPath
    If StrComp(Right(diPath, Len(APS)), APS, vbTextCompare) <> 0 Then
        diPath = diPath & APS
    End If
    
    ' Validate the initial destination folder path.
    If Len(Dir(diPath, vbDirectory)) = 0 Then
        MsgBox "The initial destination folder location '" & diPath _
            & "' doesn't exist.", vbCritical, ProcName
        Exit Sub
    End If
    
    ' Build the destination folder path ('dFolderPath') by appending
    ' the subfolder and a path separator to the initial destination
    ' folder path.
    Dim dFolderPath As String: dFolderPath = diPath & dSubFolder & APS
    
    ' Validate the destination folder path i.e. create it
    ' if it doesn't exist.
    If Len(Dir(dFolderPath, vbDirectory)) = 0 Then MkDir dFolderPath
        
    ' Reference the source workbook ('swb').
    Dim swb As Workbook: Set swb = sws.Parent
    
    ' Write the destination file path to a variable ('dPath').
    Dim dPath As String: dPath = dFolderPath & swb.Name
    
    ' Move (or save) the file.
    If Len(swb.Path) > 0 Then ' the file has previously been saved
        ' Write the source file path to a variable ('sPath').
        Dim sPath As String: sPath = swb.FullName
        ' Validate the destination file path
        ' i.e. check if the source and destination file paths are equal.
        ' Note that the comparison is case-insensitive due to 'vbTextCompare'.
        If StrComp(sPath, dPath, vbTextCompare) = 0 Then
            MsgBox "You are trying to move this file to its current " _
                & "location ('" & sPath & "').", vbExclamation, ProcName
            Exit Sub
        End If
        Application.DisplayAlerts = False ' overwrite (without confirmation)
            swb.SaveAs dPath ' save as new
        Application.DisplayAlerts = True
        Kill sPath ' delete old
    Else ' the file has previously not been saved
        dPath = dPath & dNotSavedFileExtension ' apppend the file extension
        Application.DisplayAlerts = False ' overwrite (without confirmation)
            swb.SaveAs dPath, dNotSavedFileFormat ' use 'FileFormat'
        Application.DisplayAlerts = True
    End If
            
    ' Inform showing the destination file path.
    If InformWhenMoved Then
        MsgBox "The new file location is '" & dPath & "'.", _
            vbInformation, ProcName
    End If
    
    ' Explore the destination file path's folder.
    If ExploreNewLocation Then swb.FollowHyperlink swb.Path

End Sub