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

steallan

Active Member
Joined
Oct 20, 2004
Messages
304
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
 

Some videos you may like

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

John_w

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,124
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.

Code:
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

Active Member
Joined
Oct 20, 2004
Messages
304
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.
 

steallan

Active Member
Joined
Oct 20, 2004
Messages
304
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

Active Member
Joined
Oct 20, 2004
Messages
304
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

MrExcel MVP
Joined
Oct 15, 2007
Messages
6,124
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:
VBA Code:
    If Right(destinationFolder, 1) <> "\" Then destinationFolder = sourceFolder & "\"
should be:
VBA Code:
    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.

VBA Code:
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

Active Member
Joined
Oct 20, 2004
Messages
304
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.
 

Forum statistics

Threads
1,089,299
Messages
5,407,448
Members
403,143
Latest member
CTremblay

This Week's Hot Topics

  • help please
    SORRY NOT ANY GOOD AT EXCEL SO HELP WOULD BE MUCH APPRECIATED this formula is in a sheet called ignore...
  • two formulas needed
    Hello, I'll try my best to explain this: First formula needed in Sheet1 cell A2: If Sheet1 cell B2 = Sheet2 cell B2 then return a 1. If not then...
  • Dynamic Counts
    Good afternoon, we are tidying up some data & the data seems to be growing quicker than we are tidying it up! What we confirm (by reviewing it...
  • Help Excel formula eliminate duplicate values and keep only 2 identical rows.
    as picture below column A has a duplicate value. but the values are not the same as the rule. sometimes 4 rows, sometimes 10 rows or 7 or 9...
  • Macro Compile Error Sub or Function not defined
    Hello, I am trying to run macros from a validation list, all macros have been created and run perfectly on there own but I'm getting a compile...
  • Last row combined with Current Region VBA
    I'm generally happy finding the last row of data through something like Lastrow = Cells(Rows.Count, "D").End(xlUp) but I don't always receive data...
Top