Сортировка файлов по папкам в EXCEL по имени ячейки

[дамир]

Добрый день! Помогите пожалуйста автоматизировать сортировку файлов по папкам. Есть много файлов в папке с названиями this_file_001, this_file_002, this_file_003 и т.д. они прописаны в таблице. И перед каждым таким файлом в таблице записано название папки, в которую этот файл должен попасть. Возможно есть макрос?

[boa]

Добрый день,
макроса нет, но есть команда в VBA FileCopy
Вот основываясь на данной команде и напишите себе макрос

[дамир]

Мне нужно сделать чтобы он проверял ячейки, допустим, Если есть папка с названием ячейки А1 и есть файл с названием ячейки D1 то переместить файл D1 в папку A1. Для меня программирование тяжело даётся.

Нашёл скрипт, попробовал переделать его под свою задачу, но он выдаёт ошибку.

Код: (vb)

Sub Move_File()
    Dim sFileName As String, sNewFileName As String
 
    sFileName = "C:\новая папка\this_file_001"    'имя исходного файла
    sNewFileName = "D:\новая папка\02\"    'имя файла для перемещения. Директория(в данном случае диск D) должна существовать
    If Dir(sFileName, 16) = "" Then MsgBox "Нет такого файла", vbCritical, "Ошибка": Exit Sub
 
    Name sFileName As sNewFileName 'перемещаем файл
    MsgBox "Файл перемещен", vbInformation, "www.excel-vba.ru"
End Sub

Помогите пожалуйста переделать его

[boa]

Код: (vb)

Sub Move_File()
    Dim sFileName As String, sNewFileName As String
    Dim iRow&: iRow = 1
 Do While Cells(iRow, 4) <> ""
    sFileName = Cells(iRow, 4)    'имя исходного файла
    If Dir(sFileName, 16) <> "" Then
       sNewFileName = Cells(iRow, 1) & "\" & Dir(sFileName, vbNormal + vbHidden + vbSystem)    'имя файла для перемещения. Директория должна существовать
   
       Name sFileName As sNewFileName 'перемещаем файл
    end if
 Loop
    MsgBox "Файл перемещен", vbInformation, "www.excel-vba.ru"
End Sub

[дамир]

Это всё хорошо, но я не понял как это применить, запускаю макрос, и всё зависает. И в самом скрипте я не увидел куда вписать сам путь до папки, в которой эти все файлы находятся.

[boa]

я не понял как это применить

да я и сам не знаю
Вы ж приложили файл, как того требуют правила форума, но я не умею гадать по фотографиям

[дамир]

Я просто скопировал этот скрипт, нажал Alt+F11 и вставил в новый макрос. Но когда запускаю скрипт всё зависает.

[boa]

Я понял, шутка не прошла,
Приложите файл в формате xls согласно правил форума.
А то ваше "вставил", ни о чем не говорит...

[дамир]

Так-же как на картинке у меня просто текст записан в ячейках, прикрепил файл

[vikttur]

дамир, помогающему нужно копировть макрос, вставить в файл... Это нужно кому - Вам или помогающему? Вы этого не могли сделать? Вы сами должны приложить максимум усилий для прибжения помощи!

Я просто скопировал... вставил... Но когда запускаю скрипт всё зависает.

Ну, так показать же ошибку надо, наверное? А Вы - то картинки показываете, то файлы без макроса... И при этом ждете адекватной помощи.

[дамир]

Вот файл с макросом, он не сохранился в файле.

[boa]

теперь понятнее.
у вас папки 01, 02 и т.п. расположены на планете Земля? или у них все же есть конкретный путь на диске типа "c:\Documents\01"
так вот в колонке A должны быть полные пути к будущему расположению, а в колонке D к текущему файлу
напрмер: А - "c:\Documents\01",  а D - "c:\Documents\this_file_001.xls"
и все будет работать

[boa]

ну или тогда уже так

Код: (vb)

Sub Move_File()
    Dim sFileName As String, sNewFileName As String
    Dim iRow&: iRow = 1
 
 On Error Resume Next
 Do While Cells(iRow, 4) <> ""
    sFileName = Cells(iRow, 4) & ".xls"    'имя исходного файла
    If Dir(ThisWorkbook.Path & "\" & sFileName, 16) <> "" Then
'       sNewFileName = Cells(iRow, 1) & "\" & Dir(sFileName, vbNormal + vbHidden + vbSystem)    'имя файла для перемещения. Директория должна существовать
       sNewFileName = ThisWorkbook.Path & "\" & Cells(iRow, 1) & "\" & sFileName    'имя файла для перемещения. Директория должна существовать
       If Dir(ThisWorkbook.Path & "\" & Cells(iRow, 1), vbDirectory) = "" Then MkDir (ThisWorkbook.Path & "\" & Cells(iRow, 1)) ' создаем отсутствующую папку
       Name ThisWorkbook.Path & "\" & sFileName As sNewFileName 'перемещаем файл
    End If
    iRow = iRow + 1
    DoEvents    ' что бы прервать при зависании
 Loop
    MsgBox "Файлы перемещены", vbInformation, "www.excel-vba.ru"
End Sub

сорри, забыл в первом макросе счетчик поставить iRow = iRow + 1

[vikttur]

Код: (vb)

Sub CopyFiles()
Dim aData()
'Dim fso As Object
Dim sPath As String, Folder As String, sFName As String
Dim i As Long
Const sPachFiles As String = "C:\TestFiles\"
Const sNewPach As String = "C:\TempFolder\"
    aData = Worksheets("Лист1").Range("A1:D9").Value
'    Set fso = CreateObject("scripting.FileSystemObject")
    
    With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With
    If Dir(sNewPach, vbDirectory) = "" Then MkDir sNewPach ' создаем, если нет

    For i = 1 To UBound(aData)
        sFName = sPachFiles & aData(i, 4) & ".xlsx"

        If Dir(sFName, 16) <> "" Then ' если файл есть
            sFolder = sNewPach & aData(i, 1) & "\"
            If Dir(sFolder, vbDirectory) = "" Then MkDir sFolder

'            fso.CopyFile sFName, sFolder & aData(i, 4) & ".xlsx", False
            Name sFName As sFolder & aData(i, 4) & ".xlsx"
        End If
    Next i
    
'    Set fso = Nothing
    With Application: .ScreenUpdating = True: .DisplayAlerts = True: End With
    MsgBox "OK", 64, ""
End Sub

Если не перемещать файлы, а копировать:
раскомметировать строки с fso и закомментировать строку перемещения

Код: (vb)

Name sFName As sFolder & aData(i, 4) & ".xlsx"