Question

我想：

首次提示：要求用户选择包含所有压缩文件夹的文件夹，其中每个压缩文件夹包含一个数据文件。

第二次提示：要求用户选择主文件夹路径以放置解压缩的数据文件。

程序将解压缩第一个压缩文件夹，复制数据文件，将数据文件粘贴到指定的主文件夹中，提示用户从第二个提示中选择。

程序将找到下一个压缩文件夹，解压缩并打开文件夹，复制它包含的文件，将文件粘贴到主文件夹中，重复直到每个压缩文件夹中的所有文件都被移动。

我正在尝试创建一个包含所有压缩数据文件的文件夹，以便将所有数据连接到主文档中。然后我将对这些数据进行分析。

此代码适用于未压缩的文件夹。我需要代码来识别压缩文件夹和＆＃34; * .csv＆＃34;文件的每个压缩文件夹都包含。

Option Explicit
Public FolderPath As FileDialog

'This program copies files from multiple folder locations into one folder location.

Sub CopyFiles()

Dim objFSO As Object 'FileSystemObject
Dim objFile As Object 'File
Dim objFolder As Object 'Folder
Dim strFolder As String
Dim strNewFolder As String

'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

'Retrieve target master workbook data folder path from user
Set FolderPath = Application.FileDialog(msoFileDialogFolderPicker)

With FolderPath
    .Title = "Select a master folder location to store the unzipped files."
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo CancelSelect1
    strNewFolder = .SelectedItems(1) & "\"
End With

'In case Cancel selected
CancelSelect1:
strNewFolder = strNewFolder
If strNewFolder = "" Then GoTo ResetSettings

'Retrieve target data folder path from user
Set FolderPath = Application.FileDialog(msoFileDialogFolderPicker)

With FolderPath
    .Title = "Select folder location that contains the zipped folders with desired data files."
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo CancelSelect2
    strFolder = .SelectedItems(1) & "\"
End With

'In case Cancel selected
CancelSelect2:
strFolder = strFolder
If strFolder = "" Then GoTo ResetSettings

Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFolder In objFSO.GetFolder(strFolder & "\").SubFolders
'If Right(objFolder.Name, 2) = "tb" Then
    For Each objFile In objFolder.Files
        'If InStr(1, objFile.Type, "Excel", vbTextCompare) Then
            On Error Resume Next
            Kill strNewFolder & "\" & objFile.Name
            Err.Clear: On Error GoTo 0

            Name objFile.Path As strNewFolder & "\" & objFile.Name
        'End If
    Next objFile
'End If
Next objFolder

'Reset Macro Optimization Settings
ResetSettings:
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayAlerts = True

'Message Box when tasks are completed
MsgBox "Task Complete!"
Application.Cursor = xlDefault

End Sub

Answer 1

以下是如何遍历目录，获取所有zip文件并将项目（CSV文件）复制到新位置的示例。您需要添加对Microsoft Shell控件和自动化的引用

Sub UnzipFile(savePath As String, originalPath As String)
Dim oApp As Shell
Dim strFile As String
'get a shell object
Set oApp = CreateObject("Shell.Application")
    'get all the files in the directory that are zip files
    strFile = Dir(originalPath & "*.zip")
    'loop until we cannot find anymore files
    Do While strFile <> ""
            'check to see if the zip contains items
            If oApp.Namespace(originalPath & strFile).Items.Count > 0 Then
                Dim i As Integer
                'loop through all the items in teh zip file
                For i = 0 To oApp.Namespace(originalPath & strFile).Items.Count - 1
                    'check to see if it is a CSV file
                    If UCase(Right(oApp.Namespace(originalPath & strFile).Items.Item(i), 3)) = "CSV" Then
                        'save the files to the new location
                        oApp.Namespace(savePath).CopyHere oApp.Namespace(originalPath & strFile).Items.Item(i)
                    End If
                Next i
            End If
        'get the next file in the directory
        strFile = Dir
    Loop
'free memory
Set oApp = Nothing

End Sub

通过循环过程将多个子文件夹中的压缩文件移动到一个主文件夹中

1 个答案: