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