Как да копирам или премествам файлове от една папка в друга въз основа на списък в Excel?
Ако имате списък с имена на файлове в колона в работен лист и файловете се намират в папка на вашия компютър. Но сега трябва да преместите или копирате тези файлове, чиито имена са изброени в работния лист от оригиналната им папка в друга, както е показано на следната екранна снимка. Как бихте могли да завършите тази задача възможно най-бързо в Excel?
Копирайте или преместете файлове от една папка в друга въз основа на списък в Excel с VBA код
Копирайте или преместете файлове от една папка в друга въз основа на списък в Excel с VBA код
За да преместите файловете от една папка в друга въз основа на списък с имена на файлове, следният VBA код може да ви направи услуга, моля, направете следното:
1. Задръжте натиснат Alt + F11 клавиши в Excel и отваря Microsoft Visual Basic за приложения прозорец.
2. Щракнете Поставете > Модулии поставете следния 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
Най-добрите инструменти за продуктивност в офиса
Усъвършенствайте уменията си за Excel с Kutools за Excel и изпитайте ефективност, както никога досега. Kutools за Excel предлага над 300 разширени функции за повишаване на производителността и спестяване на време. Щракнете тук, за да получите функцията, от която се нуждаете най-много...
Раздел Office Внася интерфейс с раздели в Office и прави работата ви много по-лесна
- Разрешете редактиране и четене с раздели в Word, Excel, PowerPoint, Publisher, Access, Visio и Project.
- Отваряйте и създавайте множество документи в нови раздели на един и същ прозорец, а не в нови прозорци.
- Увеличава вашата производителност с 50% и намалява стотици кликвания на мишката за вас всеки ден!