Question

我的目标是将指定文件夹及其内容从现有位置移动到标有＆＃34;存档＆＃34;的新文件夹路径中。 2000年我需要大约1000个文件夹移动到这个新位置。我有一个.xlsx文件，其中包含需要移动的每个文件夹的文件路径，列在Excel工作表的A列中。我希望我的宏查看Excel文件，读取文件夹路径，将该文件夹及其内容移动到新目标。重复Excel列表，直到它变成空白，然后它被认为＆＃34;完成！＆＃34;

这是我到目前为止找到的代码（见下文）。此代码会将一个文件夹从一个路径移动到另一个路径。我需要增强它来从我的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

使用VBA在excel文件中使用文件路径移动文件夹

1 个答案: