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

#### steallan

##### Active Member
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

### Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.

#### John_w

##### MrExcel MVP
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
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

##### MrExcel MVP
Change that line to Dim Sh As Object.

#### steallan

##### Active Member
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
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
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
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.

1,102,185
Messages
5,485,246
Members
407,490
Latest member
leogaleleo84

### This Week's Hot Topics

• Finding issue in If elseif else with For each Loop
Finding issue in If elseif else with For each Loop I have tried this below code but i'm getting in Y column filled with W005. Colud you please...
• MsgBox Error
Hi Guys, I have the below error show up when i try and run my macro in File1 but works fine if i copy and paste the same code into file2. [ATTACH...
• CELL FORMAT - IF CONDITION
My Cell Format is [B]""0.00" Cr". [/B]But in the cell, it is showing 123.00 for editing. (123 is entry figure). (Data imported from other...
• Show numbers nearly the same
Is this possible. I have a number that can change very time eg 0.00001234 Then I have a lot of numbers 0.0000001, 0.0000002, 0.00000004...