使用VBA在Excel文件中使用文件路徑移動文件夾

Question

我的目標是將指定的文件夾及其內容從現有位置移到標記為“存檔”的新文件夾路徑中。 在2000個文件夾中，大約有1000個文件夾需要轉移到這個新位置。 我有一個.xlsx文件，其中包含需要移動的每個文件夾的文件路徑，這些文件路徑在Excel工作表的A列中列出。 我希望我的宏查看Excel文件，讀取文件夾路徑，將該文件夾及其內容移動到新的目標位置。 重復瀏覽Excel列表，直到其變為空白，然后將其視為“完成！”。

這是我到目前為止找到的代碼（請參見下文）。 此代碼會將一個文件夾從一個路徑移動到另一路徑。 我需要增強它以從Excel文件讀取每個路徑； 我只是不知道命令的那一部分應該是什么樣子。

代碼和代碼中的任何注釋均深表感謝！ 謝謝！

Sub Move_Rename_Folder()
    'This example move the folder from FromPath to ToPath.
    Dim fso As Object
    Dim FromPath As String
    Dim ToPath As String
    FromPath = "Q:\Corporate-Shares\...\Test folder 1" '<< Change
    ToPath = "Q:\Corporate-Shares\...\Test Archive Folder" '<< Change
    'Note: It is not possible to use a folder that exist in ToPath

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    Set fso = CreateObject("scripting.filesystemobject")
    If fso.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If fso.FolderExists(ToPath) = True Then
        MsgBox ToPath & " exist, not possible to move to a existing folder"
        Exit Sub
    End If

    fso.MoveFolder Source:=FromPath, Destination:=ToPath
    MsgBox "The folder is moved from " & FromPath & " to " & ToPath
 End Sub

Answer 1

在使用原始文件之前，請在測試文件夾中測試此代碼。 創建副本或虛擬文件，任何失敗都可能損壞您的現有文件。

首先，使用路徑的名稱和目的地分離此移動功能：

Sub Move_Rename_Folder(FromPath as string, ToPath as string)


    'to do these two lines, go to tools, references and add Microsoft.Scripting.Runtime 
    'it's a lot easier to work like this
    Dim fso As FileSystemObject
    Set fso = new FileSystemObject

    'you don't need to set paths anymore, they come as the arguments for this sub

    If Right(FromPath, 1) = "\" Then
        FromPath = Left(FromPath, Len(FromPath) - 1)
    End If

    If Right(ToPath, 1) = "\" Then
        ToPath = Left(ToPath, Len(ToPath) - 1)
    End If

    If fso.FolderExists(FromPath) = False Then
        MsgBox FromPath & " doesn't exist"
        Exit Sub
    End If

    If fso.FolderExists(ToPath) = True Then
        MsgBox ToPath & " exist, not possible to move to a existing folder"
        Exit Sub
    End If

    fso.MoveFolder Source:=FromPath, Destination:=ToPath
    MsgBox "The folder is moved from " & FromPath & " to " & ToPath
 End Sub

然后，創建一個主Sub來運行“ B”列（從路徑）和“ C”列（到路徑），例如：

Sub MainSub()
     Dim CurrentFrom as Range, CurrentTo as Range

     'get B2, assuming your B1 is a header, not a folder
     Set CurrentFrom = ThisWorkbook.Worksheets("yoursheetname").Range("B2")
     'get C2, assuming your C1 is a header
     Set CurrentTo = ThisWorkbook.Worksheets("yoursheetname").Range("C2")

     'get the actual values - paths - from cells
     Dim ToPath as string, FromPath as string
     ToPath = CurrentTo.value     
     FromPath = CurrentFrom.Value

     'loop while your current frompath is not empty
     Do while FromPath <> ""
         'calls the move function from frompath to topath
         Call Move_Rename_Folder(FromPath, ToPath)

         'offsets the cells one row down
         Set CurrentFrom = CurrentFrom.Offset(1,0)
         Set CurrentTo = CurrentTo.Offset(1,0)

         'gets the values of the new cells
         FromPath = CurrentFrom.Value
         ToPath = CurrentTo.Value
     Loop
End Sub