Страницы: 1
RSS
Копирование файлов в разные папки по списку
 
Приветствую!
Нужно скопировать файлы, лежащие в одной папке, в список других папок
Есть два столбца:
- Папка в которую нужно скопировать файлы
- Файлы указанные через разделитель (разделитель можно изменить), которые нужно скопировать в указанную папку.
Заранее благодарен.
 
MMAXX95, у вас файлы и папки без адресов
 
и не только это ... было бы несколько других дел ... а теперь например это:
Код
Option Explicit

Sub abc_xyz()
    Const pth_src$ = "C:\Temp\0_Source\"    ' <== !!! Iskhodnyy katalog
    Const pth_trgt$ = "C:\Temp\0_Target\"   ' <== !!! Katalog naznacheniya
    Const dltr$ = "|"                       ' Razdelitel'
    
    'Net iskhodnogo kataloga, net raboty !!!
    If Dir(pth_src, vbDirectory) = "" Then MsgBox "Net iskhodnoy papki - Konets 'filma'": Exit Sub
    
    'Otsutstvuyet katalog naznacheniya ? Budet sozdan
    If Dir(pth_trgt, vbDirectory) = "" Then MkDir pth_trgt
    
    Dim ext$, flnme$, flpth$, fls, i&, ind&, r&: r = 2
    
    Do Until Trim(Cells(r, "A").Value) = ""
        flpth = pth_trgt & Trim(Cells(r, "A").Value) & "\"
        fls = Split(Application.Trim(Cells(r, "B").Value), dltr, -1, 1)
        ind = UBound(fls)
        
        'Otsutstvuyet katalog naznacheniya ? Budet sozdan
        If Dir(flpth, vbDirectory) = "" Then MkDir flpth
        
        For i = 0 To ind
            'Iskhodnyy fayl sushchestvuyet v iskhodnom kataloge, tak nachinayem rabotat'
            If Dir(pth_src & fls(i), vbNormal) <> "" Then
                'Fayl uzhe sushchestvuyet v kataloge i meshayet nam ? Delayem kopiyu etoy "meshalki-meshatelya"
                If Dir(flpth & fls(i), vbNormal) <> "" Then
                    ext = Split(fls(i), ".", -1, 1)(UBound(Split(fls(i), ".", -1, 1)))
                    'Tol'ko odna tochka v imeni fayla, inache budet oshibka !!!
                    flnme = Split(fls(i), ".", -1, 1)(UBound(Split(fls(i), ".", -1, 1)) - 1)
                    On Error Resume Next
                        'Kopiya fayla budet sdelana tol'ko odin raz !!!
                        Name flpth & fls(i) As flpth & flnme & "_old." & ext
                        If Err.Number <> 0 Then
                            MsgBox "Kopii predydushchikh faylov uzhe sushchestvuyut v kataloge !" & vbCrLf & _
                            "Sdelayte poryadok v svoikh faylakh !" & vbCrLf & "Konets 'filma'"
                            End
                        End If
                    On Error GoTo 0
                End If
                FileCopy pth_src & fls(i), flpth & fls(i)
            End If
        Next
        
        r = r + 1
    Loop
End Sub
 
Код
Sub main()
' --------------------------------
    Dim ikey, text$, arr(), i&
    Const PATH_IN$ = "Папка плучатель\"
    Const PATH_OUT$ = "Папка отправитель\"
    Dim pathold$, pathnew$
    Dim objFSO As Object
    Dim NOT_COPYED_OBJECT$
' --------------------------------
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    arr = ActiveSheet.[a1].CurrentRegion.Value
    On Error Resume Next
    For i = 2 To UBound(arr, 1)
        For Each ikey In Split(arr(i, 2), "|")
            pathnew = PATH_IN & arr(i, 1) & Application.PathSeparator & ikey
            pathold = PATH_OUT & ikey
            objFSO.copyfile pathold, pathnew
            If Err.Number <> 0 Then NOT_COPYED_OBJECT = NOT_COPYED_OBJECT & ikey & ";": Err.Clear
        Next ikey
        NOT_COPYED_OBJECT = NOT_COPYED_OBJECT & vbNewLine
    Next i
    MsgBox "Не скопированные объекты: " & vbNewLine & NOT_COPYED_OBJECT
End Sub
Изменено: Nordheim - 11.11.2019 09:12:00
"Все гениальное просто, а все простое гениально!!!"
Страницы: 1
Наверх