Macro to move zip file from one location to another, extract, then delete zip if possible

[steallan]

Hi

Can anyone help me by writing a macro that can move a zip file from a specific folder, put it in a new specific folder elsewhere on the drive, extract it in that location, then delete the zip?

The delete is the least important part. When it moves it initially it would be best if it was cut, but if its easier to copy and paste that works as well.

The main trick is identifying the zip file to move. I need the macro to do this itself by finding yesterday's date in the file name, and if the word TAP is present.

Example filename:

20191113 - UU TAP Form Return - 44.zip

so the code would have to find that, today. So something like Filename Contains System date (yyyymmdd) -1, and "TAP". The date my not be at the start of the name, but eslewhere in the string.

My VBA skills are capable of little more than altering addresses in existing code, i've got no chance of being able to write this myself.

If anyone can help, i'd really appreciate it.

Thanks

Ste

 

[John_w]

Try this macro. Note that it doesn't move or copy the zip file, but simply unzips it to the destination folder and deletes it from its original folder. Any existing files in the destination folder are overwritten. Whilst testing, and before running the macro, I suggest you copy the zip file to a different folder if you want to restore it.

Change the sourceFolder and destinationFolder strings as required.

Public Sub Find_and_Unzip()

    Dim sourceFolder As String, destinationFolder As String
    Dim zipFileName As String, foundZipFileName As String
    Dim Sh As Shell32.Shell
    Dim CopyHereFlags As Variant
                
    sourceFolder = "C:\path\to\zip files\"         'source folder containing .zip file to be unzipped
    destinationFolder = "C:\path\to\unzipped\"     'destination folder for .zip file's unzipped contents
    
    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
    If Right(destinationFolder, 1) <> "\" Then destinationFolder = sourceFolder & "\"
    
    'https://docs.microsoft.com/en-us/windows/desktop/shell/folder-copyhere
    '   4   Do not display a progress dialog box.
    '   16  Respond with "Yes to All" for any dialog box that is displayed.
    
    CopyHereFlags = 4 + 16
    
    'Find yesterday's .zip file
    
    foundZipFileName = ""
    zipFileName = Dir(sourceFolder & "*" & Format(Date - 1, "yyyymmdd") & "*.zip")
    While zipFileName <> vbNullString And foundZipFileName = ""
        If InStr(1, zipFileName, "TAP", vbTextCompare) Then foundZipFileName = zipFileName
        zipFileName = Dir()
    Wend
    
    If foundZipFileName <> "" Then
    
        'Unzip all files in the .zip file to the destination folder
            
        Set Sh = CreateObject("Shell.Application")
        With Sh
            'Note - Namespace argument enclosed in brackets to force 'pass by value'
            .Namespace((destinationFolder)).CopyHere .Namespace((sourceFolder & foundZipFileName)).Items, CopyHereFlags
        End With
    
        'Delete the .zip file
        
        Kill sourceFolder & foundZipFileName
        
        MsgBox sourceFolder & foundZipFileName & " unzipped to " & destinationFolder, vbInformation
        
    Else
    
        MsgBox "There are no matching files in " & sourceFolder, vbExclamation
    
    End If
    
End Sub

 

[steallan]

Thanks John this is amazing! Looks to be just what I need, but I get an error when i run it on:

User-Defined type not defined

on:

Sh As Shell32.Shell


alas I lack the skills to know why.

 

[John_w]

Change that line to Dim Sh As Object.

 

[steallan]

It works like a charm! Thanks a million. There's actually a few types of files in the same folder, i'll be able to use slightly different versions of this code as a Run Before event in a few different workflows, to COMPLETELY automate processes.

John, you're great, thank you again.

 

[steallan]

Is there anyway to change it slightly to not delete the folder that the unzipped files were in?

the folder creation might be a result of my manual extract process. When I do it manually, the files are placed into a folder sharing the zip file's name. That folder was really handy as the zip file name contains useful info about the files within. Namely the date.

if no such folder actually exists, can the macro create one of the same name as the zip file and put the files in there?

 

[John_w]

I don't see how the macro is deleting the destination folder, however I've just noticed a bug which would put the unzipped files in the incorrect folder.

This line:

    If Right(destinationFolder, 1) <> "\" Then destinationFolder = sourceFolder & "\"

should be:

    If Right(destinationFolder, 1) <> "\" Then destinationFolder = destinationFolder & "\"

As for putting the unzipped files in a folder with the same name as the zip file, and creating it if it doesn't exist, please try this macro. Also, instead of hard-coding the source and destination folders, I've added 2 folder browse dialogues. Note that the destination folder (browsed or hard-coded), should be the parent folder of the subfolder in which the files will be unzipped. This subfolder will be created with the same name as the .zip file, without the .zip extension, if it doesn't exist.

Public Sub Find_and_Unzip2()

    Dim fd As FileDialog
    Dim sourceFolder As String, destinationFolder As String
    Dim zipFileName As String, foundZipFileName As String
    Dim Sh As Object
    Dim CopyHereFlags As Variant
               
'    sourceFolder = "C:\path\to\zip files\"         'source folder containing .zip file to be unzipped
'    destinationFolder = "C:\path\to\unzipped\"     'parent folder containing a subfolder, same name as the .zip file and created if it doesn't exist, for .zip file's unzipped contents

'    If Right(sourceFolder, 1) <> "\" Then sourceFolder = sourceFolder & "\"
'    If Right(destinationFolder, 1) <> "\" Then destinationFolder = destinationFolder & "\"
   
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    With fd
        .Title = "Select the folder containing zip files"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show = False Then Exit Sub
        sourceFolder = .SelectedItems(1) & "\"
    End With
   
    With fd
        .Title = "Select the parent folder containing destination subfolder for unzipped files"
        .AllowMultiSelect = False
        .InitialFileName = sourceFolder 'Application.DefaultFilePath
        If .Show = False Then Exit Sub
        destinationFolder = .SelectedItems(1) & "\"
    End With
   
    'https://docs.microsoft.com/en-us/windows/desktop/shell/folder-copyhere
    '   4   Do not display a progress dialog box.
    '   16  Respond with "Yes to All" for any dialog box that is displayed.
   
    CopyHereFlags = 4 + 16
   
    'Find yesterday's .zip file
   
    foundZipFileName = ""
    zipFileName = Dir(sourceFolder & "*" & Format(Date - 1, "yyyymmdd") & "*.zip")
    While zipFileName <> vbNullString And foundZipFileName = ""
        If InStr(1, zipFileName, "TAP", vbTextCompare) Then foundZipFileName = zipFileName
        zipFileName = Dir()
    Wend
   
    If foundZipFileName <> vbNullString Then
   
        'Create final destination folder if it doesn't exist
       
        destinationFolder = destinationFolder & Left(foundZipFileName, InStrRev(foundZipFileName, ".") - 1)
        If Dir(destinationFolder, vbDirectory) = vbNullString Then MkDir destinationFolder
       
        'Unzip all files in the .zip file to the destination folder
       
        Set Sh = CreateObject("Shell.Application")
        With Sh
            'Note - Namespace argument enclosed in brackets to force 'pass by value'
            .Namespace((destinationFolder)).CopyHere .Namespace((sourceFolder & foundZipFileName)).Items, CopyHereFlags
        End With
   
        'Delete the .zip file
       
        Kill sourceFolder & foundZipFileName
       
        MsgBox sourceFolder & foundZipFileName & " unzipped to " & destinationFolder, vbInformation
       
    Else
   
        MsgBox "There are no matching files in " & sourceFolder, vbExclamation
   
    End If
   
End Sub

 

[steallan]

Glorious, is the best word to describe that macro. Works like a charm and I get my files in my correctly named folder.

Its unlikely i'll ever bump into you and be able to buy you a pint John, but I hope so.

Thank you.