VBA Unzip multiple zipped files

EMcK01

Board Regular
Joined
Jun 14, 2015
Messages
103
Hi,

I am trying to update a script that I found in another post that unzips multiple folders in a loop. Unzip files using excel macro.

The script is this:
VBA Code:
Sub UnZipMe()

Dim str_FILENAME As String, str_DIRECTORY As String, str_DESTINATION As String

'Your directory where zip file is kept
str_DIRECTORY = "C:\Test\"

'Loop through all zip files in a given directory
str_FILENAME = Dir(str_DIRECTORY & "*.zip")

Do While Len(str_FILENAME) > 0
    Call Unzip1(str_DIRECTORY & str_FILENAME)
    Debug.Print str_FILENAME
    str_FILENAME = Dir
Loop

End Sub

Sub Unzip1(str_FILENAME As String)
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Dim strDate As String

    'Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=False)
    Fname = str_FILENAME
                                        
                                        
    If Fname = False Then
        'Do nothing
    Else
        'Root folder for the new folder.
        'You can also use
        DefPath = "C:\Test\EXTRACT\"
'        DefPath = Application.DefaultFilePath
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

        'Create the folder name
        strDate = Format(Now, " dd-mm-yy h-mm-ss")
        FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"

        'Make the normal folder in DefPath
        MkDir FileNameFolder

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

        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).Items

        'If you want to extract only one file you can use this:
        'oApp.Namespace(FileNameFolder).CopyHere _
         'oApp.Namespace(Fname).items.Item("test.txt")

        'MsgBox "You find the files here: " & FileNameFolder
        Debug.Print "You find the files here: " & FileNameFolder

        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.DeleteFolder Environ("Temp") & "\Temporary Directory*", True
    End If
End Sub

All is fine with the above code, however when I try and alter it to keep the original folder name as part of the code, it only unzips a single file.

I've only changed the following and can't see why this is causing an issue

Code:
'Create the folder name
'        strDate = Format(Now, " dd-mm-yy h-mm-ss")
'        FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"
        
        FN = Dir(str_FILENAME)
        FILE = Left(FN, Len(FN) - 4)
        
        FileNameFolder = DefPath & FILE & "\"

Can someone point out where I am going wrong

PS, I'm aware there will be a much more efficient way of getting the only the file name but this appeared to work for me just now.

Thanks
 

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.

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,872
Office Version
  1. 2010
Platform
  1. Windows
Did you step through the original code? I think Dir only gives you one file name. It is the following loop that gets all the file names.
 

EMcK01

Board Regular
Joined
Jun 14, 2015
Messages
103
Hi, thanks for your reply.

Yes I had walked through it so wasn't seeing why it was an issue. Removing
VBA Code:
FN = Dir(str_FILENAME)
from the code continues the loop so I'll re-look at how I'm generating the original file name.

Thanks
 

yky

Well-known Member
Joined
Jun 7, 2011
Messages
1,872
Office Version
  1. 2010
Platform
  1. Windows
What is the complete Sub UnZipMe()? Would you post it?
 

EMcK01

Board Regular
Joined
Jun 14, 2015
Messages
103
Both Sub UnZipMe and Sub Unzip1 were posted above, but are noted within the one VBA code.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,163
Messages
5,640,496
Members
417,148
Latest member
pe3087te

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top