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

Регистрация

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

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

Старая форма входа

Страница 2 из 2 « 1 2
Модератор форума: китин, _Boroda_

Копирование файлов из одной папки в другую по условию (Макросы/Sub)

Копирование файлов из одной папки в другую по условию

Дата: Пятница, 18.01.2019, 00:23 | Сообщение № 21

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

krosav4ig,

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

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

Ответить

Дата: Пятница, 18.01.2019, 00:25 | Сообщение № 22

Группа: Друзья

Ранг: Экселист

Сообщений: 5660

Репутация: 1163 ±

Замечаний: 0% ±

2010

Цитата Anis625, 17.01.2019 в 23:59, в сообщении № 17 ()

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

Вообще-то, я не это имел в виду.

№11
[vba]

Код

For Each iFile In Folder.Files
If iFile.Name Like

[/vba]
файл iFile худо-бедно был.
№12
[vba]

Код

If iFile.Name Like

[/vba]
файл iFile мыши съели?

Быть или не быть, вот в чем загвоздка!

Ответить

Дата: Пятница, 18.01.2019, 00:30 | Сообщение № 23

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

RAN,

Цитата Anis625, 18.01.2019 в 00:05, в сообщении № 18 ()

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

???

Цитата RAN, 18.01.2019 в 00:25, в сообщении № 22 ()

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

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

Ответить

Дата: Пятница, 18.01.2019, 11:09 | Сообщение № 24

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

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

Переложил рабочий (на моем компьютере) код krosav4ig, в свой файл но только путь указал на свой обменник (общая папка по предприятию):
[vba]

Код

sInPath = "\\10.**.***.*\папка\подпапка"

[/vba]

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

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

Ответить

Дата: Пятница, 18.01.2019, 12:09 | Сообщение № 25

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2566

Репутация: 724 ±

Замечаний: 0% ±

Excel 2010

Цитата Anis625, 18.01.2019 в 11:09, в сообщении № 24 ()

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

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

Яндекс: 410016850021169

Ответить

Дата: Пятница, 18.01.2019, 12:52 | Сообщение № 26

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

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

Ответить

Дата: Пятница, 18.01.2019, 13:44 | Сообщение № 27

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

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

Ответить

Дата: Пятница, 18.01.2019, 13:49 | Сообщение № 28

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

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

[vba]

Код

sInPath = "file:\\10.**.***.*\папка\подпапка"

[/vba]

Path not found

Ответить

Дата: Пятница, 18.01.2019, 13:54 | Сообщение № 29

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

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

[vba]

Код

sInPath = "file:\\10.**.***.*\папка\подпапка\"

[/vba]

Path not found

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

Ответить

Дата: Пятница, 18.01.2019, 18:25 | Сообщение № 30

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 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

Ответить

Дата: Пятница, 18.01.2019, 18:48 | Сообщение № 31

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

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

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

Ответить

Дата: Пятница, 18.01.2019, 19:34 | Сообщение № 32

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

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

Ответить

Дата: Воскресенье, 20.01.2019, 09:13 | Сообщение № 33

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

krosav4ig,

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

К сообщению приложен файл: 8978254.png (17.7 Kb)

Ответить

Дата: Воскресенье, 20.01.2019, 09:19 | Сообщение № 34

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

krosav4ig,

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

Код

oFile.Copy sCopyTo & "\" & oFile.Name

[/vba]

Ответить

Дата: Понедельник, 21.01.2019, 10:06 | Сообщение № 35

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

_Boroda_, Manyasha, SLAVICK, китин

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

Ответить

Дата: Понедельник, 21.01.2019, 12:01 | Сообщение № 36

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2566

Репутация: 724 ±

Замечаний: 0% ±

Excel 2010

Цитата Anis625, 20.01.2019 в 09:19, в сообщении № 34 ()

sCopyTo

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

Код

sOutPath = "F:\PQ\Копирование между папками\Куда"

[/vba]

Яндекс: 410016850021169

Ответить

Дата: Понедельник, 21.01.2019, 13:22 | Сообщение № 37

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

sboy,

Цитата sboy, 21.01.2019 в 12:01, в сообщении № 36 ()

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

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

Цитата sboy, 21.01.2019 в 12:01, в сообщении № 36 ()

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

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

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

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

Ответить

Дата: Понедельник, 21.01.2019, 13:40 | Сообщение № 38

Группа: Заблокированные

Ранг: Ветеран

Сообщений: 674

Репутация: 31 ±

Замечаний: 20% ±

Excel 2013

krosav4ig, sboy,

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

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

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

Ответить

Дата: Понедельник, 21.01.2019, 17:40 | Сообщение № 39

Группа: Друзья

Ранг: Старожил

Сообщений: 2347

Репутация: 997 ±

Замечаний: 0% ±

Excel 2007,2010,2013

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

Цитата Anis625, 20.01.2019 в 09:13, в сообщении № 33 ()

Не найден сетевой путь

[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]

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

Цитата Anis625, 20.01.2019 в 09:13, в сообщении № 33 ()

Не найден сетевой путь

[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

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

Сообщение отредактировал krosav4ig - Понедельник, 21.01.2019, 17:43

Ответить

Сообщениено для локальных путей макорс из 30 поста будет выдавать ошибку

Цитата Anis625, 20.01.2019 в 09:13, в сообщении № 33 ()

Не найден сетевой путь

[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

Копирование файлов из одной папки в другую по условию (Макросы/Sub)

Страница 2 из 2
«
1
2

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