Як скопіювати або перемістити файли з однієї папки в іншу на основі списку в Excel? 

Якщо у вас є список імен файлів у стовпці на аркуші, а файли знаходяться в папці на вашому комп'ютері. Але тепер вам потрібно перемістити або скопіювати ці файли, імена яких вказані на аркуші, з їх вихідної папки в іншу, як показано на наступному знімку екрана. Як ви могли виконати це завдання якомога швидше в Excel?

Копіюйте або переміщуйте файли з однієї папки в іншу на основі списку в Excel із кодом VBA

Копіюйте або переміщуйте файли з однієї папки в іншу на основі списку в Excel із кодом VBA

Щоб перемістити файли з однієї папки в іншу на основі списку імен файлів, такий код VBA може зробити вам послугу, зробіть так:

1. Утримуйте клавішу Alt + F11 клавіші в Excel, і він відкриває Microsoft Visual Basic для додатків вікна.

2. Клацання Insert > Модуліта вставте наступний код VBA у вікно модуля.

Код VBA: переміщення файлів з однієї папки в іншу на основі списку в Excel

Sub movefiles()
'Updateby Extendoffice
    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As Variant, xDPathStr As Variant
    Dim xVal As String
    On Error Resume Next
    Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = " Please select the original folder:"
    If xSFileDlg.Show <> -1 Then Exit Sub
    xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = " Please select the destination folder:"
    If xDFileDlg.Show <> -1 Then Exit Sub
    xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
    For Each xCell In xRg
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
            FileCopy xSPathStr & xVal, xDPathStr & xVal
            Kill xSPathStr & xVal
        End If
    Next
End Sub

3. А потім натисніть F5 клавішу для запуску цього коду, і з'явиться підказка, щоб нагадати вам про вибір комірок, що містять імена файлів, див. знімок екрана:

4. Потім натисніть OK і у спливаючому вікні виберіть папку, яка містить файли, з яких ви хочете перемістити, див. знімок екрана:

5. А потім клацніть OK, перейдіть до вибору цільової папки, де ви хочете знайти файли, в іншому спливаючому вікні, див. знімок екрана:

6. Нарешті, клацніть OK щоб закрити вікно, і тепер файли були переміщені в іншу папку, яку ви вказали на основі імен файлів у списку робочих аркушів, див. знімок екрана:

примітки: Якщо ви просто хочете скопіювати файли в іншу папку, але зберегти оригінальні файли, застосуйте наведений нижче код VBA:

Код VBA: копіюйте файли з однієї папки в іншу на основі списку в Excel

Sub copyfiles()
'Updateby Extendoffice
    Dim xRg As Range, xCell As Range
    Dim xSFileDlg As FileDialog, xDFileDlg As FileDialog
    Dim xSPathStr As Variant, xDPathStr As Variant
    Dim xVal As String
    On Error Resume Next
    Set xRg = Application.InputBox("Please select the file names:", "KuTools For Excel", ActiveWindow.RangeSelection.Address, , , , , 8)
    If xRg Is Nothing Then Exit Sub
    Set xSFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xSFileDlg.Title = "Please select the original folder:"
    If xSFileDlg.Show <> -1 Then Exit Sub
    xSPathStr = xSFileDlg.SelectedItems.Item(1) & "\"
    Set xDFileDlg = Application.FileDialog(msoFileDialogFolderPicker)
    xDFileDlg.Title = "Please select the destination folder:"
    If xDFileDlg.Show <> -1 Then Exit Sub
    xDPathStr = xDFileDlg.SelectedItems.Item(1) & "\"
    For Each xCell In xRg
        xVal = xCell.Value
        If TypeName(xVal) = "String" And xVal <> "" Then
            FileCopy xSPathStr & xVal, xDPathStr & xVal
        End If
    Next
End Sub