Перемещение файлов по папкам - VBA

Формулировка задачи:

Добрый день товарищи! есть код макроса, которым я пользуюсь для перемещения определенных файлов xlsx по заданным папкам. но его громоздкость и не универсальность в том, что для каждого файла написана процедура перемещения, и имена соответственно фиксированы. а можно ли подкорректировать код так, чтобы выполнялось перемещения файла в папку в зависимости от содержания имени файла: т.е. если в имени файла содержится слово

one

, переместил его в папку

One

, нашел слово

three

перенес его в папку

Three

и тд. всего папок 3 и ключевых слов соответственно тоже 3

                    Листинг программы
                
 
                            
                        
Sub FileToFolder()
 
MkDir ("C:\One")  'создаем 3 директории
MkDir ("C:\Two")
MkDir ("C:\Three")
 
    sFileName = "C:\Users\papi\Desktop\Temp\one1.xlsx"      'путь к файлу
    sNewFileName = "C:\One\one1.xlsx" 'имя файла для перемещения
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    Name sFileName As sNewFileName  'перемещаем файл
    
    sFileName = "C:\Users\papi\Desktop\Temp\one2.xlsx"
    sNewFileName = "C:\One\one2.xlsx"
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    Name sFileName As sNewFileName
    
    sFileName = "C:\Users\papi\Desktop\Temp\two1.xlsx"
    sNewFileName = "C:\Two\two1.xlsx"
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    Name sFileName As sNewFileName
    
    sFileName = "C:\Users\papi\Desktop\Temp\two2.xlsx"
    sNewFileName = "C:\Two\two2.xlsx"
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    Name sFileName As sNewFileName
    
    sFileName = "C:\Users\papi\Desktop\Temp\two3.xlsx"
    sNewFileName = "C:\Two\two3.xlsx"
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    Name sFileName As sNewFileName
    
    sFileName = "C:\Users\papi\Desktop\Temp\three1.xlsx"
    sNewFileName = "C:\Three\three1.xlsx"
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    Name sFileName As sNewFileName
    
    sFileName = "C:\Users\papi\Desktop\Temp\three2.xlsx"
    sNewFileName = "C:\Three\three2.xlsx"
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
    Name sFileName As sNewFileName
    
End Sub

с уважением

Решение задачи: «Перемещение файлов по папкам»

textual
                            Листинг программы 
                        
 
                        
                          
                    
Dim names() as String
names = Array("one","two","three")
fn= dir("C:\Users\papi\Desktop\Temp\*.xlsx")
while fn<>""
  For i=0 to Ubound(names)
    if fn like "*" & names(i) & "*.xlsx" then
      Name "C:\Users\papi\Desktop\Temp\" & fn As "C:\" & names(i) & "\" & fn
    end if
  next i
  fn=dir
wend