Перемещение папок в другой каталог - PullRequest
Новая
       18

Перемещение папок в другой каталог

0 голосов
/ 10 марта 2020

Я недавно разместил здесь вопрос о перемещении файлов в другой каталог ( Перемещение файлов в другой каталог ), теперь я хочу переместить папки, которые затем будут заархивированы.

Макет то же самое с существующей папкой в ​​A, целью в B и столбцом C, чтобы подтвердить, если завершено.

image example

Предоставленный код был 

Sub move_files()
    Dim i As Long
    With ActiveSheet
        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            Err.Clear
            On Error Resume Next
            Name (.Cells(i, 1)) As .Cells(i, 2) & "\" & StrReverse(Split(StrReverse(.Cells(i, 1)), "\")(0))
            If Err = 0 Then .Cells(i, 3) = "YES" Else .Cells(i, 3) = "NO"
            On Error GoTo 0
        Next
    End With
End Sub

Учитывая, что я пытаюсь переместить весь столбец, кто-нибудь знает, можно ли адаптировать вышеперечисленное для перемещения папки, поскольку в настоящее время она работает только для файлов. Я искал в Интернете, но обычно только для одного файла.

1 Ответ

1 голос
/ 10 марта 2020

Это пересмотренная версия только для перемещения папок. Надеюсь, это сработает. 

Sub move_folders()
  Dim i As Long
  Dim oFSO As Object
  Dim sep As String

  Set oFSO = CreateObject("Scripting.FileSystemObject")
  With ActiveSheet
    For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
      Err.Clear
      If Left(StrReverse(.Cells(i, 2)), 1) = "\" Then sep = "" Else sep = "\"
      On Error Resume Next
      oFSO.MoveFolder .Cells(i, 1), .Cells(i, 2) & sep & StrReverse(Split(StrReverse(.Cells(i, 1)), "\")(0))
      If Err = 0 Then .Cells(i, 3) = "YES" Else .Cells(i, 3) = "NO"
      On Error GoTo 0
    Next
  End With
End Sub
...