Do any of the files with the last piece (234567.docx) have spaces?

i.e.

ME-102 - Cabinet, Biosafety, 6 ft 2345 67.docx --> \ME-102 - Cabinet, Biosafety, 6 ft

Otherwise, you can just Split() the file name and build the new path

 
Option Explicit

'ME-102 - Cabinet, Biosafety, 6 ft 234567.docx ids moved to ME-102 - Cabinet, Biosafety, 6 ft folder
'18-430.1 - Imaging Device, X-Ray Unit, Rad, Digital -TRANSFER.docx is moved to 18-430.1 - Imaging Device, X-Ray Unit, Rad, Digital folder


Sub MoveFiles()
    Dim sFile1 As String, sFile2 As String, sPath1 As String, sPath2 As String
    Dim v As Variant
    Dim i As Long
    
    
    'inputs
    sPath1 = "d:\Test"
    sPath2 = "d:\Test1\"
    
    sFile1 = "ME-102 - Cabinet, Biosafety, 6 ft 234567.docx"
    
    'get rid of last part
    v = Split(sFile1, " ")
    
    For i = LBound(v) To UBound(v) - 1
        sFile2 = sFile2 & v(i) & " "
    Next i


    sFile2 = Left(sFile2, Len(sFile2) - 1)
       
    Name (sPath1 & "\" & sFile1) As sPath2 & sFile2 & "\" & sFile1
End Sub


No error checking and no folder creation

The work to loop the file list, etc. is left as an assignment for the reader