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

Вход

Регистрация

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

 

= Мир MS Excel/Копирование файлов из одной папки в другую по условию - Страница 2 - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 2 из 2
  • «
  • 1
  • 2
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование файлов из одной папки в другую по условию (Макросы/Sub)
Копирование файлов из одной папки в другую по условию
Anis625 Дата: Пятница, 18.01.2019, 00:23 | Сообщение № 21
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
krosav4ig,

Вот это крууууто. Все отлично работает. Спасибо Вам за помощь в решении вопроса. Очень выручили.

P.S. Это космос для меня такое написать =)
 
Ответить
Сообщениеkrosav4ig,

Вот это крууууто. Все отлично работает. Спасибо Вам за помощь в решении вопроса. Очень выручили.

P.S. Это космос для меня такое написать =)

Автор - Anis625
Дата добавления - 18.01.2019 в 00:23
RAN Дата: Пятница, 18.01.2019, 00:25 | Сообщение № 22
Группа: Друзья
Ранг: Участник клуба
Сообщений: 5000
Репутация: 994 ±
Замечаний: 0% ±

2010
Но правила есть правила =) Добавил.

Вообще-то, я не это имел в виду. %)
№11
[vba]
Код
For Each iFile In Folder.Files
If iFile.Name Like
[/vba]
файл iFile худо-бедно был.
№12
[vba]
Код
If iFile.Name Like
[/vba]
файл iFile мыши съели?


Быть или не быть, вот в чем загвоздка!
 
Ответить
Сообщение
Но правила есть правила =) Добавил.

Вообще-то, я не это имел в виду. %)
№11
[vba]
Код
For Each iFile In Folder.Files
If iFile.Name Like
[/vba]
файл iFile худо-бедно был.
№12
[vba]
Код
If iFile.Name Like
[/vba]
файл iFile мыши съели?

Автор - RAN
Дата добавления - 18.01.2019 в 00:25
Anis625 Дата: Пятница, 18.01.2019, 00:30 | Сообщение № 23
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
RAN,
А Вы когда первый сели за руль велосипеда, автомобиля у вас сразу хорошо получилось ехать? Или вам тоже говорили >1 раза как правильно нужно это делать?

???

файл iFile мыши съели?


Я пока не все вопросы которые вы спрашиваете понимаю. Учусь.
 
Ответить
СообщениеRAN,
А Вы когда первый сели за руль велосипеда, автомобиля у вас сразу хорошо получилось ехать? Или вам тоже говорили >1 раза как правильно нужно это делать?

???

файл iFile мыши съели?


Я пока не все вопросы которые вы спрашиваете понимаю. Учусь.

Автор - Anis625
Дата добавления - 18.01.2019 в 00:30
Anis625 Дата: Пятница, 18.01.2019, 11:09 | Сообщение № 24
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
Первый раз с таким вопросом:

Переложил рабочий (на моем компьютере) код krosav4ig, в свой файл но только путь указал на свой обменник (общая папка по предприятию):
[vba]
Код
sInPath = "\\10.**.***.*\папка\подпапка"
[/vba]

И макрос эту папку не видит. Нужно ли в этом случае что-то дописать или с общими серверными папками макросы не работают?

Я всегда думал, что это как обычная папка.
 
Ответить
СообщениеПервый раз с таким вопросом:

Переложил рабочий (на моем компьютере) код krosav4ig, в свой файл но только путь указал на свой обменник (общая папка по предприятию):
[vba]
Код
sInPath = "\\10.**.***.*\папка\подпапка"
[/vba]

И макрос эту папку не видит. Нужно ли в этом случае что-то дописать или с общими серверными папками макросы не работают?

Я всегда думал, что это как обычная папка.

Автор - Anis625
Дата добавления - 18.01.2019 в 11:09
sboy Дата: Пятница, 18.01.2019, 12:09 | Сообщение № 25
Группа: Друзья
Ранг: Старожил
Сообщений: 2447
Репутация: 689 ±
Замечаний: 0% ±

Excel 2010
И макрос эту папку не видит

Как проверяли? FSO.FolderExists?


Яндекс: 410016850021169
 
Ответить
Сообщение
И макрос эту папку не видит

Как проверяли? FSO.FolderExists?

Автор - sboy
Дата добавления - 18.01.2019 в 12:09
Anis625 Дата: Пятница, 18.01.2019, 12:52 | Сообщение № 26
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
sboy,
получается не проверял. Попробую поискать
 
Ответить
Сообщениеsboy,
получается не проверял. Попробую поискать

Автор - Anis625
Дата добавления - 18.01.2019 в 12:52
Anis625 Дата: Пятница, 18.01.2019, 13:44 | Сообщение № 27
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
sboy,

Я попробовал макрокодером записать одно действие: зашел в сетевую папку и подпапку и в ней открыл файл:

[vba]
Код
Sub Макрос1()
    Workbooks.Open Filename:= _
        "\\10.**.***.*\папка\подпапка\Документ.xlsx"
    Windows("Книга1").Activate
End Sub
[/vba]

Макрос записался в модуле. Потом закрыл файл. Запустил макрос и ... файл открылся.

Странно. Почему тогда макрос:

[vba]
Код
Sub test()
    Dim sInPath$, sOutPath$, oFSO As Object
    
    sInPath = "\\10.**.***.*\папка\подпапка"
    sOutPath = "F:\PQ\Копирование между папками\Куда"
    
    Set oFSO = CreateObject("scripting.filesystemobject")
    
    CopyRecursive oFSO, sInPath, sOutPath, "*.xls*"
        
    Set oFSO = Nothing
End Sub
Private Sub CopyRecursive(ByRef oFSO As Object, sCopyFrom$, sCopyTo$, sMask$)
    Dim oFile As Object, oFolder As Object
    Set oFolder = oFSO.GetFolder(sCopyFrom)
    For Each oFile In oFolder.Files
        If oFile.Name Like "*+*.xls*" Then oFile.Copy sCopyTo & "\" & oFile.Name
    Next
    For Each oFolder In oFolder.SubFolders
        CopyRecursive oFSO, oFolder.Path, sCopyTo, sMask
    Next
    Set oFile = Nothing
    Set oFolder = Nothing
End Sub
[/vba]

выводится сообщение Path not found


Сообщение отредактировал Anis625 - Пятница, 18.01.2019, 13:49
 
Ответить
Сообщениеsboy,

Я попробовал макрокодером записать одно действие: зашел в сетевую папку и подпапку и в ней открыл файл:

[vba]
Код
Sub Макрос1()
    Workbooks.Open Filename:= _
        "\\10.**.***.*\папка\подпапка\Документ.xlsx"
    Windows("Книга1").Activate
End Sub
[/vba]

Макрос записался в модуле. Потом закрыл файл. Запустил макрос и ... файл открылся.

Странно. Почему тогда макрос:

[vba]
Код
Sub test()
    Dim sInPath$, sOutPath$, oFSO As Object
    
    sInPath = "\\10.**.***.*\папка\подпапка"
    sOutPath = "F:\PQ\Копирование между папками\Куда"
    
    Set oFSO = CreateObject("scripting.filesystemobject")
    
    CopyRecursive oFSO, sInPath, sOutPath, "*.xls*"
        
    Set oFSO = Nothing
End Sub
Private Sub CopyRecursive(ByRef oFSO As Object, sCopyFrom$, sCopyTo$, sMask$)
    Dim oFile As Object, oFolder As Object
    Set oFolder = oFSO.GetFolder(sCopyFrom)
    For Each oFile In oFolder.Files
        If oFile.Name Like "*+*.xls*" Then oFile.Copy sCopyTo & "\" & oFile.Name
    Next
    For Each oFolder In oFolder.SubFolders
        CopyRecursive oFSO, oFolder.Path, sCopyTo, sMask
    Next
    Set oFile = Nothing
    Set oFolder = Nothing
End Sub
[/vba]

выводится сообщение Path not found

Автор - Anis625
Дата добавления - 18.01.2019 в 13:44
Anis625 Дата: Пятница, 18.01.2019, 13:49 | Сообщение № 28
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
Так тоже пробовал

[vba]
Код
sInPath = "file:\\10.**.***.*\папка\подпапка"
[/vba]

Path not found
 
Ответить
СообщениеТак тоже пробовал

[vba]
Код
sInPath = "file:\\10.**.***.*\папка\подпапка"
[/vba]

Path not found

Автор - Anis625
Дата добавления - 18.01.2019 в 13:49
Anis625 Дата: Пятница, 18.01.2019, 13:54 | Сообщение № 29
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
Так тоже пробовал

[vba]
Код
sInPath = "file:\\10.**.***.*\папка\подпапка\"
[/vba]

Path not found


Сообщение отредактировал Anis625 - Пятница, 18.01.2019, 13:56
 
Ответить
СообщениеТак тоже пробовал

[vba]
Код
sInPath = "file:\\10.**.***.*\папка\подпапка\"
[/vba]

Path not found

Автор - Anis625
Дата добавления - 18.01.2019 в 13:54
krosav4ig Дата: Пятница, 18.01.2019, 18:25 | Сообщение № 30
Группа: Друзья
Ранг: Старожил
Сообщений: 2032
Репутация: 847 ±
Замечаний: 0% ±

Excel 2007,2010,2013
пробуйте так[vba]
Код
Option Explicit
Sub test()
    Dim sInPath$, sOutPath$, oFSO As Object, sUser$, sPass$
    
    sUser = "ИмяПользователя": sPass = "Пароль" 'нужно ввести учетные данные на обменнике
    sInPath = "\\10.**.***.*\папка\подпапка"
    sOutPath = "F:\PQ\Копирование между папками\Куда"
    
    With CreateObject("WScript.Network")
        .MapNetworkDrive "", sInPath, False, sUser, sPass
        
        Set oFSO = CreateObject("scripting.filesystemobject")
        CopyRecursive oFSO, sInPath, sOutPath, "*.xls*"
        Set oFSO = Nothing
        
        .RemoveNetworkDrive sInPath, True, False
    End With
    
End Sub
Private Sub CopyRecursive(ByRef oFSO As Object, sCopyFrom$, sCopyTo$, sMask$)
    Dim oFile As Object, oFolder As Object
    Set oFolder = oFSO.GetFolder(sCopyFrom)
    For Each oFile In oFolder.Files
        If oFile.Name Like "*+*.xls*" Then oFile.Copy sCopyTo & "\" & oFile.Name
    Next
    For Each oFolder In oFolder.SubFolders
        CopyRecursive oFSO, oFolder.Path, sCopyTo, sMask
    Next
    Set oFile = Nothing
    Set oFolder = Nothing
End Sub
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Пятница, 18.01.2019, 18:26
 
Ответить
Сообщениепробуйте так[vba]
Код
Option Explicit
Sub test()
    Dim sInPath$, sOutPath$, oFSO As Object, sUser$, sPass$
    
    sUser = "ИмяПользователя": sPass = "Пароль" 'нужно ввести учетные данные на обменнике
    sInPath = "\\10.**.***.*\папка\подпапка"
    sOutPath = "F:\PQ\Копирование между папками\Куда"
    
    With CreateObject("WScript.Network")
        .MapNetworkDrive "", sInPath, False, sUser, sPass
        
        Set oFSO = CreateObject("scripting.filesystemobject")
        CopyRecursive oFSO, sInPath, sOutPath, "*.xls*"
        Set oFSO = Nothing
        
        .RemoveNetworkDrive sInPath, True, False
    End With
    
End Sub
Private Sub CopyRecursive(ByRef oFSO As Object, sCopyFrom$, sCopyTo$, sMask$)
    Dim oFile As Object, oFolder As Object
    Set oFolder = oFSO.GetFolder(sCopyFrom)
    For Each oFile In oFolder.Files
        If oFile.Name Like "*+*.xls*" Then oFile.Copy sCopyTo & "\" & oFile.Name
    Next
    For Each oFolder In oFolder.SubFolders
        CopyRecursive oFSO, oFolder.Path, sCopyTo, sMask
    Next
    Set oFile = Nothing
    Set oFolder = Nothing
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 18.01.2019 в 18:25
Anis625 Дата: Пятница, 18.01.2019, 18:48 | Сообщение № 31
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
krosav4ig,
Эээхх =) с работы ушел уже.

Обратил внимание что добавили запрос на ввод пароля. Так то у нас пароль не запрашивает. Попробовать стоит.
А как макрос на открытие файла срабатывает без манипуляций, а с папками нужны танцы с бубнами?
 
Ответить
Сообщениеkrosav4ig,
Эээхх =) с работы ушел уже.

Обратил внимание что добавили запрос на ввод пароля. Так то у нас пароль не запрашивает. Попробовать стоит.
А как макрос на открытие файла срабатывает без манипуляций, а с папками нужны танцы с бубнами?

Автор - Anis625
Дата добавления - 18.01.2019 в 18:48
Anis625 Дата: Пятница, 18.01.2019, 19:34 | Сообщение № 32
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
У меня правда только логин и пароль для входа в ПК есть. Админовских паролей не знаю если они нужны будут
 
Ответить
СообщениеУ меня правда только логин и пароль для входа в ПК есть. Админовских паролей не знаю если они нужны будут

Автор - Anis625
Дата добавления - 18.01.2019 в 19:34
Anis625 Дата: Воскресенье, 20.01.2019, 09:13 | Сообщение № 33
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
krosav4ig,

Не срабатывает макрос. Выдает ошибку - Не найден сетевой путь
К сообщению приложен файл: 8978254.png(17.7 Kb)
 
Ответить
Сообщениеkrosav4ig,

Не срабатывает макрос. Выдает ошибку - Не найден сетевой путь

Автор - Anis625
Дата добавления - 20.01.2019 в 09:13
Anis625 Дата: Воскресенье, 20.01.2019, 09:19 | Сообщение № 34
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
krosav4ig,

Попробовал Ваш предыдущий файл (при копировании с жесткого диска на жесткий) сохранить в модуле. Пишет Path not found и нажав Debug ругается на эту часть:
[vba]
Код
oFile.Copy sCopyTo & "\" & oFile.Name
[/vba]
 
Ответить
Сообщениеkrosav4ig,

Попробовал Ваш предыдущий файл (при копировании с жесткого диска на жесткий) сохранить в модуле. Пишет Path not found и нажав Debug ругается на эту часть:
[vba]
Код
oFile.Copy sCopyTo & "\" & oFile.Name
[/vba]

Автор - Anis625
Дата добавления - 20.01.2019 в 09:19
Anis625 Дата: Понедельник, 21.01.2019, 10:06 | Сообщение № 35
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
_Boroda_, Manyasha, SLAVICK, китин

Переместите, пожалуйста, в платный раздел
 
Ответить
Сообщение_Boroda_, Manyasha, SLAVICK, китин

Переместите, пожалуйста, в платный раздел

Автор - Anis625
Дата добавления - 21.01.2019 в 10:06
sboy Дата: Понедельник, 21.01.2019, 12:01 | Сообщение № 36
Группа: Друзья
Ранг: Старожил
Сообщений: 2447
Репутация: 689 ±
Замечаний: 0% ±

Excel 2010
sCopyTo

Если бы Вы сразу сказали, что дебаг эту строку показывает, то не ждали бы так долго)
в этой переменной путь КУДА копируем. Проверьте адрес. Возможно Вы еще не создали эту папку?
[vba]
Код
sOutPath = "F:\PQ\Копирование между папками\Куда"
[/vba]


Яндекс: 410016850021169
 
Ответить
Сообщение
sCopyTo

Если бы Вы сразу сказали, что дебаг эту строку показывает, то не ждали бы так долго)
в этой переменной путь КУДА копируем. Проверьте адрес. Возможно Вы еще не создали эту папку?
[vba]
Код
sOutPath = "F:\PQ\Копирование между папками\Куда"
[/vba]

Автор - sboy
Дата добавления - 21.01.2019 в 12:01
Anis625 Дата: Понедельник, 21.01.2019, 13:22 | Сообщение № 37
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
sboy,

Если бы Вы сразу сказали, что дебаг эту строку показывает, то не ждали бы так долго)


Дебаг вышел после того я макрос попробовал в модуль зашить

Проверьте адрес. Возможно Вы еще не создали эту папку?


Папка точно есть, т.к. макрос работает при копировании в пределах своего ПК (жесткого диска).

НО ... я не знаю, что изменилось, т.к. я не менял ровным счетом ничего.

Я макрос krosav4ig, снова зашил в модуль, путь сетевой папки в этот раз скопировал со свойства папки (не с адресной строки) и ... все работает. Не понимаю. Как так.
Еще раз сейчас попробую.
 
Ответить
Сообщениеsboy,

Если бы Вы сразу сказали, что дебаг эту строку показывает, то не ждали бы так долго)


Дебаг вышел после того я макрос попробовал в модуль зашить

Проверьте адрес. Возможно Вы еще не создали эту папку?


Папка точно есть, т.к. макрос работает при копировании в пределах своего ПК (жесткого диска).

НО ... я не знаю, что изменилось, т.к. я не менял ровным счетом ничего.

Я макрос krosav4ig, снова зашил в модуль, путь сетевой папки в этот раз скопировал со свойства папки (не с адресной строки) и ... все работает. Не понимаю. Как так.
Еще раз сейчас попробую.

Автор - Anis625
Дата добавления - 21.01.2019 в 13:22
Anis625 Дата: Понедельник, 21.01.2019, 13:40 | Сообщение № 38
Группа: Проверенные
Ранг: Обитатель
Сообщений: 256
Репутация: 3 ±
Замечаний: 0% ±

Excel 2013
krosav4ig, sboy,

Ну работает же макрос. Только аккуратно с выбором папки: задал всю сетевую папку и макрос начал отрабатывать все папки, завис ... пришлось перезапускать Excel (но до завершения сеанса очень много файлов успел скопировать по заданному условию.

Попробовал на необходимой папке (в которой 384 подпапок и 1162 файла) макрос отработал за секунд 30.

Огромная благодарность всем кто принял участие и отдельная благодарность krosav4ig, Надеюсь эта тема будет индексироваться в поисковиках и сможет помочь другим тоже.
 
Ответить
Сообщениеkrosav4ig, sboy,

Ну работает же макрос. Только аккуратно с выбором папки: задал всю сетевую папку и макрос начал отрабатывать все папки, завис ... пришлось перезапускать Excel (но до завершения сеанса очень много файлов успел скопировать по заданному условию.

Попробовал на необходимой папке (в которой 384 подпапок и 1162 файла) макрос отработал за секунд 30.

Огромная благодарность всем кто принял участие и отдельная благодарность krosav4ig, Надеюсь эта тема будет индексироваться в поисковиках и сможет помочь другим тоже.

Автор - Anis625
Дата добавления - 21.01.2019 в 13:40
krosav4ig Дата: Понедельник, 21.01.2019, 17:40 | Сообщение № 39
Группа: Друзья
Ранг: Старожил
Сообщений: 2032
Репутация: 847 ±
Замечаний: 0% ±

Excel 2007,2010,2013
но для локальных путей макорс из 30 поста будет выдавать ошибку
Не найден сетевой путь

[vba]
Код
Option Explicit
Sub test()
          Dim sInPath$, sOutPath$, oFSO As Object, sUser$, sPass$, sFolder As Variant
10    sUser = "ИмяПользователя": sPass = "Пароль" 'нужно ввести учетные данные на обменнике
20    On Error GoTo ErrHandler
30    With Application.FileDialog(4)
40        .AllowMultiSelect = False
50        .InitialFileName = "\\10.**.***.*\папка\подпапка\"
60        .Title = "Выберите папку с файлами"
70        GoSub sel
80        sInPath = .SelectedItems(1)
90        .InitialFileName = "F:\PQ\Копирование между папками\Куда\"
100       .Title = "Выберите папку назначения"
110 sel:  If .Show = False Then
120           If MsgBox("Ничего не выбрано. Повторить?", vbYesNo) = vbYes Then
130               Resume sel
140           Else
150               Exit Sub
160           End If
170       End If
180       On Error Resume Next
190       Return
200       On Error GoTo ErrHandler
210   End With

220   With CreateObject("WScript.Network")
230       For Each sFolder In Array(sInPath, sOutPath)
240           If Left(sFolder, 2) = "\\" Then .MapNetworkDrive "", sFolder, False, sUser, sPass
250       Next

260       Set oFSO = CreateObject("scripting.filesystemobject")
270       CopyRecursive oFSO, sInPath, sOutPath, "*.xls*"
280       Set oFSO = Nothing

290       For Each sFolder In Array(sInPath, sOutPath)
300           If Left(sFolder, 2) = "\\" Then .RemoveNetworkDrive sFolder, True, False
310       Next
320   End With
330   Exit Sub
ErrHandler:
340   MsgBox "Произошла ошибка " & Err.Number & "(" & Err.Description & _
          ") в модуле " & Application.VBE.ActiveCodePane.codemodule.Name & _
          " в процедуре test() на строке " & Erl
End Sub
Private Sub CopyRecursive(ByRef oFSO As Object, sCopyFrom$, sCopyTo$, sMask$)
          Dim oFile As Object, oFolder As Object
10    On Error GoTo ErrHandler
20    Set oFolder = oFSO.GetFolder(sCopyFrom)
30    For Each oFile In oFolder.Files
40        If oFile.Name Like "*+*.xls*" Then oFile.Copy sCopyTo & "\" & oFile.Name
50    Next
60    For Each oFolder In oFolder.SubFolders
70        CopyRecursive oFSO, oFolder.Path, sCopyTo, sMask
80    Next
90    Set oFile = Nothing
100   Set oFolder = Nothing
110   Exit Sub
ErrHandler:
120   MsgBox "Произошла ошибка " & Err.Number & "(" & Err.Description & _
          ") в модуле " & Application.VBE.ActiveCodePane.codemodule.Name & _
          " в процедуре CopyRecursive() на строке " & Erl
End Sub
[/vba]


email:krosav4ig26@gmail.com WMR R207627035142 WMZ Z821145374535 ЯД 410012026478460

Сообщение отредактировал krosav4ig - Понедельник, 21.01.2019, 17:43
 
Ответить
Сообщениено для локальных путей макорс из 30 поста будет выдавать ошибку
Не найден сетевой путь

[vba]
Код
Option Explicit
Sub test()
          Dim sInPath$, sOutPath$, oFSO As Object, sUser$, sPass$, sFolder As Variant
10    sUser = "ИмяПользователя": sPass = "Пароль" 'нужно ввести учетные данные на обменнике
20    On Error GoTo ErrHandler
30    With Application.FileDialog(4)
40        .AllowMultiSelect = False
50        .InitialFileName = "\\10.**.***.*\папка\подпапка\"
60        .Title = "Выберите папку с файлами"
70        GoSub sel
80        sInPath = .SelectedItems(1)
90        .InitialFileName = "F:\PQ\Копирование между папками\Куда\"
100       .Title = "Выберите папку назначения"
110 sel:  If .Show = False Then
120           If MsgBox("Ничего не выбрано. Повторить?", vbYesNo) = vbYes Then
130               Resume sel
140           Else
150               Exit Sub
160           End If
170       End If
180       On Error Resume Next
190       Return
200       On Error GoTo ErrHandler
210   End With

220   With CreateObject("WScript.Network")
230       For Each sFolder In Array(sInPath, sOutPath)
240           If Left(sFolder, 2) = "\\" Then .MapNetworkDrive "", sFolder, False, sUser, sPass
250       Next

260       Set oFSO = CreateObject("scripting.filesystemobject")
270       CopyRecursive oFSO, sInPath, sOutPath, "*.xls*"
280       Set oFSO = Nothing

290       For Each sFolder In Array(sInPath, sOutPath)
300           If Left(sFolder, 2) = "\\" Then .RemoveNetworkDrive sFolder, True, False
310       Next
320   End With
330   Exit Sub
ErrHandler:
340   MsgBox "Произошла ошибка " & Err.Number & "(" & Err.Description & _
          ") в модуле " & Application.VBE.ActiveCodePane.codemodule.Name & _
          " в процедуре test() на строке " & Erl
End Sub
Private Sub CopyRecursive(ByRef oFSO As Object, sCopyFrom$, sCopyTo$, sMask$)
          Dim oFile As Object, oFolder As Object
10    On Error GoTo ErrHandler
20    Set oFolder = oFSO.GetFolder(sCopyFrom)
30    For Each oFile In oFolder.Files
40        If oFile.Name Like "*+*.xls*" Then oFile.Copy sCopyTo & "\" & oFile.Name
50    Next
60    For Each oFolder In oFolder.SubFolders
70        CopyRecursive oFSO, oFolder.Path, sCopyTo, sMask
80    Next
90    Set oFile = Nothing
100   Set oFolder = Nothing
110   Exit Sub
ErrHandler:
120   MsgBox "Произошла ошибка " & Err.Number & "(" & Err.Description & _
          ") в модуле " & Application.VBE.ActiveCodePane.codemodule.Name & _
          " в процедуре CopyRecursive() на строке " & Erl
End Sub
[/vba]

Автор - krosav4ig
Дата добавления - 21.01.2019 в 17:40
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Копирование файлов из одной папки в другую по условию (Макросы/Sub)
  • Страница 2 из 2
  • «
  • 1
  • 2
Поиск:

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