Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Копирование файлов по части имени в списке - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование файлов по части имени в списке (Макросы/Sub)
Копирование файлов по части имени в списке
temastarwars Дата: Вторник, 24.08.2021, 20:18 | Сообщение № 1
Группа: Пользователи
Ранг: Прохожий
Сообщений: 1
Репутация: 0 ±
Замечаний: 0% ±

Привет, форумчане! Нужна помощь в доработке макроса. Имеется макрос для копирования файлов из одной папки в другую по части имени файла по списку в excel (макрос указан ниже).
Просьба помочь доработать его для:
- копирования файлов из папки с учетом подпапок;
- выделения цветом (либо прописать в соседнем столбце) в реестре excel тех файлов, которые не нашлись (не скопировались).
[vba]
Код
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
CreateObject("WScript.Shell").Run "cmd /C COPY /Y """ & xSPathStr & "*" & xVal & "*" & """ " & """" & xDPathStr & """", 0, True
End If
Next
End Sub
[/vba]
 
Ответить
СообщениеПривет, форумчане! Нужна помощь в доработке макроса. Имеется макрос для копирования файлов из одной папки в другую по части имени файла по списку в excel (макрос указан ниже).
Просьба помочь доработать его для:
- копирования файлов из папки с учетом подпапок;
- выделения цветом (либо прописать в соседнем столбце) в реестре excel тех файлов, которые не нашлись (не скопировались).
[vba]
Код
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
CreateObject("WScript.Shell").Run "cmd /C COPY /Y """ & xSPathStr & "*" & xVal & "*" & """ " & """" & xDPathStr & """", 0, True
End If
Next
End Sub
[/vba]

Автор - temastarwars
Дата добавления - 24.08.2021 в 20:18
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование файлов по части имени в списке (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования Jobsora jooble
© 2010-2021 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!