Excel VBA-将多个文件夹解压缩到多个文件夹

Question

我已经学习VBA大约六个月了，在过去数天中，我一直在思考这个简单的问题……这是一个简单的问题，我只是没有能够找到正确的解决方案。

我的项目涉及从网站下载大量文件夹，将其全部压缩，然后处理其中包含的数据以使其可用。现在，所有处理方面都已解决，但解压缩文件夹会占用大量时间，我认为使用另一个宏很容易解决。但是，我发现的所有宏都需要往返的特定路径，而我需要的东西将解压缩指定文件夹中的所有文件夹-同时使它们按文件夹名称进行组织。他们可以解压缩到同一文件夹，甚至可以覆盖zip文件（在这种情况下没有关系），但是必须按文件夹名称进行整理-否则处理部分将无法工作。

我一直在尝试修改以下代码以实现我的目的，但仍然存在两个问题：一个-我必须选择所有文件夹（以获取路径），而不是仅仅解压缩所有文件夹（我已经尝试修改以运行每个子文件夹，但没有路径就看不到压缩文件夹，这与Dir（）一样。还有两个-它会将所有解压缩的文件转储到一个目标位置，从而使它无法进行处理。

一个简单的宏，与右键单击相同，“全部提取”，但循环遍历一个文件夹中的所有文件夹，将是完美的-但我还没有找到一个可行的宏。任何帮助或建议，将不胜感激。

这是我一直在尝试修改的代码：

Sub Button11_Click()

    Dim IPath, OPath As String, FFile, FFSo, FFolder As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim Output_Folder As Variant
    Dim strDate As String
    Dim i As Long

    IPath = "E:\R2\Input\Zipped\"
    OPath = "E:\R2\Input\"

    'Select multiple zip files to unzip
    MsgBox "Go to E:\R2\Input\Zipped\ - For Zipped folders"
    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=True)

    If IsArray(Fname) = False Then
        'Do nothing
    Else

        'For Each SFolder In AFolder.Subfolders

        'Set output folder path for unzip files
        Output_Folder = OPath

        'Extract the files into output folder
        Set oApp = CreateObject("Shell.Application")

        For i = LBound(Fname) To UBound(Fname)

            'WORKS BUT DOESN"T SEPARATE INTO FOLDERS, just dumps into input folder.
            oApp.Namespace(Output_Folder).CopyHere oApp.Namespace(Fname(i)).items

        Next i

        MsgBox "You find the files here: " & Output_Folder

    End If

End Sub

Answer 1

Else

    'For Each SFolder In AFolder.Subfolders

    'Set output folder path for unzip files
    'Output_Folder = OPath

    'Extract the files into output folder
    Set oApp = CreateObject("Shell.Application")

    For i = LBound(Fname) To UBound(Fname)
        'V Might need to update to "correct" name
        Output_Folder = Mkdir OPath & "\" & Fname(i)
        'WORKS BUT DOESN"T SEPARATE INTO FOLDERS, just dumps into input folder.
        oApp.Namespace(Output_Folder).CopyHere oApp.Namespace(Fname(i)).items

    Next i

    MsgBox "You find the files here: " & Output_Folder

End If