Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Копирование папки с помощью VBA в другой каталог
 
#1
25.09.2016 19:53:17
Всем привет! подскажите  пожалуйста  как скопировать одну папку(folder1) со всем содержимым из одного каталога в другой с переименованием т.е. конечная папка будет называться folder2
в исходной папке (folder1) файлы двух типов .xlsx и  .txt  если это упростит задачу
Заранее огромное спасибо!  
 
 
 
#2
25.09.2016 20:30:05
VBS скрипт:
Код
Option Explicit
Dim outFolder: outFolder = "C:\TEST\"
Dim inFolder: inFolder = "\\Server"
Dim oFSO: Set oFSO = CreateObject("Scripting.FileSystemObject")
Dim WSNetwork: Set WSNetwork = CreateObject("WScript.Network")
 
If oFSO.FolderExists(outFolder) AND oFSO.FolderExists(inFolder) Then
  CopyFileOnMask outFolder, "exe txt rar" ' каталог и маски файлов для копирования
  WScript.Echo "Готово."
Else
  WScript.Echo "Не найден один из путей " & outFolder & " " & "ИЛИ" & " " & inFolder
End If
WScript.Quit(0)
 
Function CopyFileOnMask(s, sMask)
  Dim oFld, iFld, arrMask, v, i, num
  num = 0
  Set oFld = oFSO.GetFolder(s)
  Set iFld = oFSO.GetFolder(inFolder)
  arrMask = Split(LCase(sMask), " ")
  For Each v In oFld.Files
    For i = LBound(arrMask) To UBound(arrMask)
      If LCase(oFSO.GetExtensionName(s & "\" & v.Name)) = arrMask(i) Then
        v.Copy(iFld & "\" & v.Name), True
      num = num + 1
      'oFSO.CopyFile v, iFld & v.Name, True
        Exit For
      End If
    Next
  Next
  If Err.Number Then
WScript.Echo "Обновление прошло с ошибками. Сообщите об этом администратору."
else
WScript.Echo "Обновление прошло успешно. Скопировано " & num & " файлов."
Err.Clear
End if
End Function
 
 
 
#3
25.09.2016 21:26:29
мне удалось получить копию папки C:\Dell с именем C:\Dell2
Код
Sub CopyFolder()
  Dim fso
  Set fso = CreateObject("scripting.filesystemobject"):  fso.CopyFolder "c:\dell", "c:\dell2"
End Sub
Изменено: Ігор Гончаренко - 25.09.2016 21:27:34
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
 
 
#4
25.09.2016 21:36:50
Ігор Гончаренко, да Ваш способ работает. Изменил свой код по мотивам вышерасположенного поста.
Вариант со сторонней библиотекой (Scripting.FileSystemObject), в самом VBA нужно делать много действий.
Код
Sub Скопировать_папку()
    
    Dim fso As Object
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
        fso.DeleteFolder "C:\Users\User\Desktop\Папка\Папка 2", True
    On Error GoTo 0
    fso.CopyFolder "C:\Users\User\Desktop\Папка 1", "C:\Users\User\Desktop\Папка\Папка 2"
    
End Sub
Изменено: Karataev - 25.09.2016 21:38:16
 
 
 
#5
27.09.2016 00:15:33
с простым копирование получилось . чтобы не плодить темы сразу в этой опишу полную задачу(хотела сама допилить но чо то не получается) : нужно скопировать три папки с датами 20160924 20160925 20160926  из папки user в папку main с именами 20160924n  и т.д. (n - это не переменная это часть имени папки) пользуюсь вот таким циклом
Код
Sub FileChecker()
Dim r As Long
'NACHALO CICLA PROVRKI NALICHIYA PAPKI
For r = 2 To Cells(Rows.Count, 3).End(xlUp).Row
Dim fso
Cells(r, 4) = Dir(Cells(1, 3) & Cells(r, 3))
'COPIRUY FAIL
Set fso = CreateObject("scripting.filesystemobject"): fso.CopyFolder "C:\user\r", "c:\main\r & _n"
'r - peremenaya' 'r & _n - imya konechnoy papki, naprimer 20160924_n
Sheets("BASE").Select
Next 'perehod k PROVRKe NALICHIYA sledyuschei PAPKI
End Sub
названия берутся из файла( см влож) на листе"base" столбец  С начиная со второй ячейки. при выполнении пишет Path not found . я так понимаю папку не находит хотя пути я перепроверяла 100 раз может чо то неправильно в тексте. Там в столбце С название папок прописаны в формате даты может это оказывает влияние
Изменено: roneta90 - 27.09.2016 00:35:04
 
 
 
#6
27.09.2016 09:54:01
Я изменил в столбце "C" формат ячеек, а чтобы даты были в нужном виде, вставил формулу. Иначе у Вас в столбце "C" фактически был не текст вида 20160925, а были числа (это можно было увидеть, если изменить формат ячеек на "Общий"). И макрос не мог найти нужную папку, т.к. у Вас имена папок вида "20160925", а в столбце "C" числа.

В функции "Dir" я добавил параметр "vbDirectory". Его нужно использовать, если нужно работать с папками.
 
 
 
#7
29.09.2016 00:31:20
ок сработало спасибо! ну надеюсь последний вопрос я адаптировала под свою задачу и в итоге за каждую дату я копирую и получаю в конечной директории(с:\main\) за каждую дату по две папки 20160924 и 20160924_n . внутри 20160924 существую файл RS_RUS_EP747_243332.txt (т.е. адрес файла C:\main\20160924\) его надо скопировать в папку 20160924_n . особенность в том что в названии  файла RS_RUS_EP747_243332.txt: RS_RUS_EP747_  - постоянная часть а "243332" меняется: я дополнила макрос макросом копирования файла,получилось так: ругается на cnhjre FileCopy sFileName, sNewFileName            eror 52 пути перепроверила вроде правильно. во вложении положила архив с директриями с:\main  c:\User с результатом выполнения копирования ПАПОК
Код
Option Explicit
Sub FileChecker()
Dim sFileName As String, sNewFileName As String
Dim sh As Worksheet, fso As Object, r As Long
    
    Set sh = Sheets("BASE")
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    'NACHALO CICLA PROVRKI NALICHIYA PAPKI
    For r = 2 To sh.Cells(sh.Rows.Count, 3).End(xlUp).Row
        sh.Cells(r, "D") = Dir(sh.Cells(1, "C") & sh.Cells(r, "C"), vbDirectory)
        'COPIRUY FAIL
        If sh.Cells(r, "D") <> "" Then
            'r - peremenaya' 'r & _n - imya konechnoy papki, naprimer 20160924_n
            fso.CopyFolder sh.Cells(1, "C") & sh.Cells(r, "C") & "\PS1", "c:\main\" & sh.Cells(r, "C")
            fso.CopyFolder sh.Cells(1, "C") & sh.Cells(r, "C") & "\PS2", "c:\main\" & sh.Cells(r, "C") & "_n"
        End If
 
 sFileName = sh.Cells(1, "G") & sh.Cells(r, "C") & "\RS_RUS_EP747*.TXT"    'имя файла для копироваия
 sNewFileName = sh.Cells(1, "G") & sh.Cells(r, "C") & "_n" & "\RS_RUS_EP747.TXT"     'имя конечного файла я переименовала его но это не важно как он в итоге будет назваться'
  If Dir(sFileName, 16) = "" Then MsgBox "нет такого файла", vbCritical, "ошибка": Exit Sub
  FileCopy sFileName, sNewFileName 'копирую
  MsgBox "файл скопирован", vbInformation
Next 'perehod k PROVRKe NALICHIYA sledyuschei PAPKI
End Sub
Изменено: roneta90 - 29.09.2016 21:04:15
 
 
 
#8
29.09.2016 03:00:11
У вас ячейка пустая  sh.Cells(1, "H")  
Код
 sNewFileName = sh.Cells(1, "H") & sh.Cells(r, "C") & "_n" & "\RS_RUS_EP747_N.TXT"  
 
 
 
#9
29.09.2016 08:39:21
А звёздочка то ведь не работает!
Код
FileCopy "C:\Downloads\inf*.pdf", "C:\Downloads\info2.pdf"
 
 
 
#10
29.09.2016 21:03:51
Цитата
Hugo написал: А звёздочка то ведь не работает!
я пробовала прописывать название файла без звездочки т.е. полностью такая же фигня и в ячейке   sh.Cells(1, "H") исправила  на sh.Cells(1, "G")
 
 
 
#11
13.04.2020 09:06:52
день добрый. Задача: из папки А нужно копировать файлы XML в папку Б. После копирования, файлы в папке А нужно перенести (именно перенести, в корне А их быть не должно по копирования)   в подпапку В. Т.е. в папке А есть папка В, а нужны файлы только в корне, файлы в подпапке В копировать не нужно.
 
 
 
Страницы: 1
Наверх