VBA code to download zip and extract csv file from it and save with specified name

playtime007

New Member
Joined
Feb 3, 2020
Messages
32
Office Version
  1. 2019
Platform
  1. Windows
I am having a simple application in excel to download all zip urls in column "C" column "C" has urls and column "Q" has names Every url has 1 zip file and every zip has 1 csv in it. What I want to do is to 1. unzip the CSV files and save them with names as mentioned in column "Q" 2. Kill all the zip 3. CSV file must be overwritten as I will be doing this task on daily basis so when the next day or next time I perform the task it must overwrite the previous file







VBA Code:
Sub Download_All()
Dim lr As Long
Dim fileurl As String, filename As String
Dim r As Long
lr = Sheets("Downloads").Range("C" & Rows.Count).End(xlUp).Row
For r = 5 To lr
    fileurl = Sheets("Downloads").Range("C" & r).Value


    If InStr(1, fileurl, ".zip") <> 0 Then
        filepath = "C:\MyDownloads\"

    End If
            Dim Obj1 As Object
    Set Obj1 = CreateObject("Microsoft.XMLHTTP")
    Obj1.Open "GET", fileurl, False
    Obj1.send
    If Obj1.Status = 200 Then
        Set Obj2 = CreateObject("ADODB.Stream")
        Obj2.Open
        Obj2.Type = 1
        Obj2.Write Obj1.responseBody
        Obj2.SaveToFile (filepath & getfilename(fileurl)), 2 ' 1 = no overwrite, 2 = overwrite

        Obj2.Close
    End If
    Next r
End Sub

Function getfilename(filepath As String)
    Dim v_string() As String
    v_string = Split(filepath, "/")
    getfilename = v_string(UBound(v_string))
End Function
 

Some videos you may like

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,973
Office Version
  1. 365
Platform
  1. Windows
UNTESTED
I think this should work

I have assumed that the files are unzipped to the same folder
If they are to be unzipped to different folder then replace filepath with the correct folder path and end the path with "\"

Insert
Call UnzipFileRename(filepath & GetFileName(fileurl), filepath, Sheets("Downloads").Range("Q" & r).Value & ".csv")
Below
Obj2.SaveToFile (filepath & getfilename(fileurl)), 2 ' 1 = no overwrite, 2 = overwrite


Place code in same module as Download_All
VBA Code:
Private Sub UnzipFileRename(zipFullName As Variant, unzipPath As Variant, newName As String)
    Dim ShellApp As Object, oldFullName As String, newfullname As String, n As Variant
    Set ShellApp = CreateObject("Shell.Application")
'get file name
    For Each n In ShellApp.Namespace(zipFullName).Items
        a = a + 1
        oldFullName = unzipPath & n.Name
        newfullname = unzipPath & newName
        If a = 1 Then Exit For
    Next n
'delete previous version to avoid any issues
    DeleteFile oldFullName
    DeleteFile newfullname
'unzip the file
    ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items
'rename the file
    Name oldFullName As newfullname
'delete zip file
    DeleteFile CStr(zipFullName)
End Sub

Private Sub DeleteFile(PathAndName As String)
    On Error Resume Next
    Kill PathAndName
    On Error GoTo 0
End Sub
 

playtime007

New Member
Joined
Feb 3, 2020
Messages
32
Office Version
  1. 2019
Platform
  1. Windows
THANKS MATE YOU SAVED MY LIFE.

Can u pls add the codes to send message Box with File Name = Download status Like below
suppose there are 3 file to be download and 1 failed it should look like

File Name = Downloaded
File Name = Downloaded
File Name =Download Failed
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,973
Office Version
  1. 365
Platform
  1. Windows
EDIT - IGNORE THIS POST- I will post simpler code in a few minutes


1. assumed that
- the code fails at ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items - is this correct ?
- and that fileurl is the required name in message box - is this correct ?

2. Procedure DeleteFile - does not change

3. In Download_All

- Amend this line to include msg
Dim fileurl As String, filename As String , msg As String

- Delete the line I gave you last time and replace with ...
msg = msg & vbCr & UnzipFileRename(fileurl, filepath & GetFileName(fileurl), filepath, Sheets("Downloads").Range("Q" & r).Value & ".csv")

- Insert this line above End Sub
MsgBox msg, vbOKOnly, "Results"

4. Delete sub UnzipFileRename - it is now a function returning required string for each file
- replace with this
VBA Code:
Private Function UnzipFileRename(FileName As String, zipFullName As Variant, unzipPath As Variant, newName As String) As String
    Dim ShellApp As Object, oldfullName As String, newfullName As String, n As Variant, a As Integer, d As String
    Set ShellApp = CreateObject("Shell.Application")
'get file name
    For Each n In ShellApp.Namespace(zipFullName).Items
        a = a + 1
        oldfullName = unzipPath & n.Name
        newfullName = unzipPath & newName
        If a = 1 Then Exit For
    Next n
'delete previous version to avoid any issues
    DeleteFile oldfullName
    DeleteFile newfullName
'unzip the file
    On Error Resume Next
    ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items
    If Err.Number = 0 Then d = " downloaded" Else d = " download failed"
    On Error GoTo 0
'rename the file
    Name oldfullName As newfullName
'delete zip file
    DeleteFile CStr(zipFullName)
    UnzipFileRename = FileName & d
End Function
 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,973
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

It was pointless passing the name variable simply to pass it back again, hence amended code

1. assumed that
- the code fails at ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items - is this correct ?
- and that fileurl is the required name in message box - is this correct ?

2. Procedure DeleteFile - does not change

3. In Download_All

- Amend this line to include msg
Dim fileurl As String, filename As String , msg As String

- Delete the line I gave you last time and replace with ...
msg = msg & vbCr & fileurl & UnzipFileRename(filepath & GetFileName(fileurl), filepath, Sheets("Downloads").Range("Q" & r).Value & ".csv")

- Insert this line above End Sub
MsgBox msg, vbOKOnly, "Results"

4. Delete sub UnzipFileRename - it is now a function returning required string for each file
- replace with this
VBA Code:
Private Function UnzipFileRename(zipFullName As Variant, unzipPath As Variant, newName As String) As String
    Dim ShellApp As Object, oldfullName As String, newfullName As String, n As Variant, a As Integer, d As String
    Set ShellApp = CreateObject("Shell.Application")
'get file name
    For Each n In ShellApp.Namespace(zipFullName).Items
        a = a + 1
        oldfullName = unzipPath & n.Name
        newfullName = unzipPath & newName
        If a = 1 Then Exit For
    Next n
'delete previous version to avoid any issues
    DeleteFile oldfullName
    DeleteFile newfullName
'unzip the file
    On Error Resume Next
    ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items
    If Err.Number = 0 Then d = " downloaded" Else d = " download failed"
    On Error GoTo 0
'rename the file
    Name oldfullName As newfullName
'delete zip file
    DeleteFile CStr(zipFullName)
    UnzipFileRename = d
End Function
 

playtime007

New Member
Joined
Feb 3, 2020
Messages
32
Office Version
  1. 2019
Platform
  1. Windows
Hi Mate,

I tried, the message is returning only for successful downloads.
The message contains only File_Name_1 = Downloaded, File_Name_2 = Downloaded But, there is no information about 3rd file for download Failed
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,973
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

UNTESTED

Rich (BB code):
After this line
ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items

Add this line
Debug.Print Err.Number , CStr(zipFullName)


Debug.Print writes to Immediate Window
{CTRL} g displays Immediate Window (when in VBA editor)

Run again
Look at Immediate Window
Is every filename written to Immediate Window ?
Which error is VBA returning when a file fails to download ?

If every line begins with a zero, then VBA is not returning an error and we must find a differerent method to return download success
- this should be possible by comparing the list in column Q with the names of csv files in folder (some will be missing)
 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,973
Office Version
  1. 365
Platform
  1. Windows
Does the code stop running when a file fails to download or does the code keep running ?
If the code stops running - where does it stop - which line is highlighted ?
 

playtime007

New Member
Joined
Feb 3, 2020
Messages
32
Office Version
  1. 2019
Platform
  1. Windows
Hi,
Modified as you said.
Nothing Changed

Immediate window also has only Successful downloaded information of 2files.

The codes stop nowhere, I put the wrong url on No.1 to check whether it stops at start but, it skipped the wrong url and downloaded next 2 with status message "Downloaded" as before

 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,973
Office Version
  1. 365
Platform
  1. Windows
If you delete these lines does the code still loop through EVERY file ?
On Error Resume Next
ShellApp.Namespace(unzipPath).CopyHere ShellApp.Namespace(zipFullName).Items
If Err.Number = 0 Then d = " downloaded" Else d = " download failed"
On Error GoTo 0
 

Watch MrExcel Video

Forum statistics

Threads
1,122,158
Messages
5,594,581
Members
413,915
Latest member
namreh

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