Need vba to download and copy the data from zip file

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
Sort by date Sort by votes
Here is the code to download ZIP file, extract CSV file from it and import CSV data to the new sheet:
Rich (BB code): 
Sub DownloadZipExtractCsvAndLoad()
'ZVI:2017-01-07 http://www.mrexcel.com/forum/excel-questions/984206-need-visual-basic-applications-download-copy-data-zip-file.html
 
  Dim UrlFile As String, ZipFile As String, CsvFile As String, Folder As String, s As String
 
  ' UrlFile to the ZIP archive with CSV file
  UrlFile = "https://www.nseindia.com/content/historical/DERIVATIVES/2016/DEC/fo26DEC2016bhav.csv.zip"
 
  ' Extract ZipFile, CsvFile from UrlFile
  ZipFile = Mid(UrlFile, InStrRev(UrlFile, "/") + 1)
  CsvFile = Left(ZipFile, Len(ZipFile) - 4)
 
  ' Define temporary folder
  Folder = Environ("TEMP") & "\"
 
  ' Disable screen updating to avoid blinking
  Application.ScreenUpdating = False
 
  ' Trap errors
  On Error GoTo exit_
 
  ' Download UrlFile to ZipFile in Folder
  If Not Url2File(UrlFile, Folder & ZipFile) Then
    MsgBox "Can't download file" & vbLf & UrlFile, vbCritical, "Error"
    Exit Sub
  End If
 
  ' Extract CsvFile from ZipFile
  If Len(Dir(Folder & CsvFile)) Then Kill Folder & CsvFile
  With CreateObject("Shell.Application").Namespace((Folder))
    .CopyHere Folder & ZipFile & "\" & CsvFile
  End With
  Kill Folder & ZipFile
 
  ' Delete temporary folders to prevent saturation of Shell.Application
  With CreateObject("Scripting.FileSystemObject")
    s = Dir(Folder & "\*" & ZipFile, vbDirectory + vbHidden)
    While Len(s)
      .DeleteFolder Folder & s, True
      s = Dir()
    Wend
  End With
 
  ' Import CsvFile to Excel
  With Workbooks.Open(Folder & CsvFile).Sheets(1)
    .UsedRange.Columns(1).TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
        FieldInfo:=Array(Array(3, 4), Array(15, 4)), TrailingMinusNumbers:=True
    ' Autofit the widths
    .UsedRange.Columns.AutoFit
    ' Copy sheet to the new workbook
    .Copy
    ' Release (close) CsvFile
    .Parent.Close False
  End With
 
  ' Delete CsvFile
  Kill Folder & CsvFile
 
exit_:
 
  ' Restore screen updating
  Application.ScreenUpdating = True
 
  ' Inform about the reason of the trapped error
  If Err Then MsgBox Err.Description, vbCritical, "Error"
 
End Sub
 
Function Url2File(UrlFile As String, PathName As String, Optional Login As String, Optional Password As String) As Boolean
'ZVI:2017-01-07 Download UrlFile and save it to PathName.
'               Use optional Login and Password if required.
'               Returns True on success downloading.
  Dim b() As Byte, FN As Integer
  On Error GoTo exit_
  If Len(Dir(PathName)) Then Kill PathName
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", UrlFile, False, Login, Password
    .send
    If .Status <> 200 Then Exit Function
    b() = .responseBody
    FN = FreeFile
    Open PathName For Binary Access Write As #FN
    Put #FN, , b()
exit_:
    If FN Then Close #FN
    Url2File = .Status = 200
  End With
End Function
 
Last edited:
Upvote 0
Hi Zvi,

I am using above code, but I need to copy the csv file to another workbook (say wb) and sheet2 from cell (I2).. please help as I am getting object not found and subscript out of range errors.

I need to copy on existing sheet from cell "I".

existing sheet: BSESTOCKS

I tried to edit the below code but getting errors like object required, subscript out of range, please help

With Workbooks.Open(Folder & CsvFile).Sheets(1)
.UsedRange.Columns(1).TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
FieldInfo:=Array(Array(3, 4), Array(15, 4)), TrailingMinusNumbers:=True
' Autofit the widths
.UsedRange.Columns.AutoFit
' Copy sheet to the new workbook
.Copy
' Release (close) CsvFile
.Parent.Close False
End With
 
Upvote 0
Hi,
Change the user constants on the top of the code to define data destination
Rich (BB code): 
Sub DownloadZipExtractCsvAndLoad_01()
'ZVI:2017-01-07 http://www.mrexcel.com/forum/excel-questions/984206-need-visual-basic-applications-download-copy-data-zip-file.html
'ZVI:2018-09-11 Updated code with destination range constants
 
  ' --> User settings, change to suit
  Const DestWorkbook = "Wb1.xlsx"
  Const DestSheet = "BSESTOCKS"
  Const DestCell = "I2"
  '<-- End of the user settings
 
  Dim UrlFile As String, ZipFile As String, CsvFile As String, Folder As String, s As String
 
  ' UrlFile to the ZIP archive with CSV file
  UrlFile = "https://www.nseindia.com/content/historical/DERIVATIVES/2016/DEC/fo26DEC2016bhav.csv.zip"
 
  ' Extract ZipFile, CsvFile from UrlFile
  ZipFile = Mid(UrlFile, InStrRev(UrlFile, "/") + 1)
  CsvFile = Left(ZipFile, Len(ZipFile) - 4)
 
  ' Define temporary folder (updated 2018-09-11)
  Folder = Environ("TEMP")
  If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
 
  ' Disable screen updating to avoid blinking
  Application.ScreenUpdating = False
 
  ' Trap errors
  On Error GoTo exit_
 
  ' Download UrlFile to ZipFile in Folder
  If Not Url2File(UrlFile, Folder & ZipFile) Then
    MsgBox "Can't download file" & vbLf & UrlFile, vbCritical, "Error"
    Exit Sub
  End If
 
  ' Extract CsvFile from ZipFile
  If Len(Dir(Folder & CsvFile)) Then Kill Folder & CsvFile
  With CreateObject("Shell.Application").Namespace((Folder))
    .CopyHere Folder & ZipFile & "\" & CsvFile
  End With
  Kill Folder & ZipFile
 
  ' Delete temporary folders to prevent saturation of Shell.Application
  With CreateObject("Scripting.FileSystemObject")
    s = Dir(Folder & "\*" & ZipFile, vbDirectory + vbHidden)
    While Len(s)
      .DeleteFolder Folder & s, True
      s = Dir()
    Wend
  End With
 
  ' Import CsvFile to Excel
  With Workbooks.Open(Folder & CsvFile).Sheets(1)
    .UsedRange.Columns(1).TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
        FieldInfo:=Array(Array(3, 4), Array(15, 4)), TrailingMinusNumbers:=True
    ' Autofit the widths
    .UsedRange.Columns.AutoFit
   
    ' Copy sheet to the new workbook
    '.Copy
   
    ' Copy data to the destination range (updated 2018-09-11)
    .UsedRange.Copy Workbooks(DestWorkbook).Sheets(DestSheet).Range(DestCell)
   
    ' Release (close) CsvFile
    .Parent.Close False
  End With
 
  ' Delete CsvFile
  Kill Folder & CsvFile
 
exit_:
 
  ' Restore screen updating
  Application.ScreenUpdating = True
 
  ' Inform about the reason of the trapped error
  If Err Then MsgBox Err.Description, vbCritical, "Error"
 
End Sub
 
Function Url2File(UrlFile As String, PathName As String, Optional Login As String, Optional Password As String) As Boolean
'ZVI:2017-01-07 Download UrlFile and save it to PathName.
'               Use optional Login and Password if required.
'               Returns True on success downloading.
  Dim b() As Byte, FN As Integer
  On Error GoTo exit_
  If Len(Dir(PathName)) Then Kill PathName
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", UrlFile, False, Login, Password
    .send
    If .Status <> 200 Then Exit Function
    b() = .responseBody
    FN = FreeFile
    Open PathName For Binary Access Write As FN 
    Put FN, , b()
exit_:
    If FN Then Close FN
    Url2File = .Status = 200
  End With
End Function
Regards
 
Last edited:
Upvote 0
Thanks ZVI,

still I am getting subscript out of range error when running the same code. at please guide. also the destination sheet name different from source sheet name.

.UsedRange.Copy Workbooks(DestWorkbook).Sheets(DestSheet).Range(DestCell)

ZVI said:
Hi,
Change the user constants on the top of the code to define data destination
Rich (BB code): 
Sub DownloadZipExtractCsvAndLoad_01()
'ZVI:2017-01-07 http://www.mrexcel.com/forum/excel-questions/984206-need-visual-basic-applications-download-copy-data-zip-file.html
'ZVI:2018-09-11 Updated code with destination range constants
 
  ' --> User settings, change to suit
  Const DestWorkbook = "Wb1.xlsx"
  Const DestSheet = "BSESTOCKS"
  Const DestCell = "I2"
  '<-- End of the user settings
 
  Dim UrlFile As String, ZipFile As String, CsvFile As String, Folder As String, s As String
 
  ' UrlFile to the ZIP archive with CSV file
  UrlFile = "https://www.nseindia.com/content/historical/DERIVATIVES/2016/DEC/fo26DEC2016bhav.csv.zip"
 
  ' Extract ZipFile, CsvFile from UrlFile
  ZipFile = Mid(UrlFile, InStrRev(UrlFile, "/") + 1)
  CsvFile = Left(ZipFile, Len(ZipFile) - 4)
 
  ' Define temporary folder (updated 2018-09-11)
  Folder = Environ("TEMP")
  If Right(Folder, 1) <> "\" Then Folder = Folder & "\"
 
  ' Disable screen updating to avoid blinking
  Application.ScreenUpdating = False
 
  ' Trap errors
  On Error GoTo exit_
 
  ' Download UrlFile to ZipFile in Folder
  If Not Url2File(UrlFile, Folder & ZipFile) Then
    MsgBox "Can't download file" & vbLf & UrlFile, vbCritical, "Error"
    Exit Sub
  End If
 
  ' Extract CsvFile from ZipFile
  If Len(Dir(Folder & CsvFile)) Then Kill Folder & CsvFile
  With CreateObject("Shell.Application").Namespace((Folder))
    .CopyHere Folder & ZipFile & "\" & CsvFile
  End With
  Kill Folder & ZipFile
 
  ' Delete temporary folders to prevent saturation of Shell.Application
  With CreateObject("Scripting.FileSystemObject")
    s = Dir(Folder & "\*" & ZipFile, vbDirectory + vbHidden)
    While Len(s)
      .DeleteFolder Folder & s, True
      s = Dir()
    Wend
  End With
 
  ' Import CsvFile to Excel
  With Workbooks.Open(Folder & CsvFile).Sheets(1)
    .UsedRange.Columns(1).TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
        FieldInfo:=Array(Array(3, 4), Array(15, 4)), TrailingMinusNumbers:=True
    ' Autofit the widths
    .UsedRange.Columns.AutoFit
   
    ' Copy sheet to the new workbook
    '.Copy
   
    ' Copy data to the destination range (updated 2018-09-11)
    .UsedRange.Copy Workbooks(DestWorkbook).Sheets(DestSheet).Range(DestCell)
   
    ' Release (close) CsvFile
    .Parent.Close False
  End With
 
  ' Delete CsvFile
  Kill Folder & CsvFile
 
exit_:
 
  ' Restore screen updating
  Application.ScreenUpdating = True
 
  ' Inform about the reason of the trapped error
  If Err Then MsgBox Err.Description, vbCritical, "Error"
 
End Sub
 
Function Url2File(UrlFile As String, PathName As String, Optional Login As String, Optional Password As String) As Boolean
'ZVI:2017-01-07 Download UrlFile and save it to PathName.
'               Use optional Login and Password if required.
'               Returns True on success downloading.
  Dim b() As Byte, FN As Integer
  On Error GoTo exit_
  If Len(Dir(PathName)) Then Kill PathName
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", UrlFile, False, Login, Password
    .send
    If .Status <> 200 Then Exit Function
    b() = .responseBody
    FN = FreeFile
    Open PathName For Binary Access Write As FN 
    Put FN, , b()
exit_:
    If FN Then Close FN
    Url2File = .Status = 200
  End With
End Function
Regards
Click to expand...
 
Upvote 0
What are names of the destination workbook and sheet?
It is required to rewrite in the code their actual names as values of the constants DestWorkbook and DestSheet.
If destination sheet is protected then upnprotect it before code running.
 
Upvote 0
Destination workbook is already open
workbook name: Autobuy.xlsm (note: its in different folder like c:\files)
worksheet name: NSEStocks.

Also, in source file there are few columns where data is empty (do u think this is the reason it throws, out of range error)
mostly in the below code we need to correct.

With Workbooks.Open(Folder & CsvFile).Sheets(1)
.UsedRange.Columns(1).TextToColumns Destination:=.Cells(1), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, _
FieldInfo:=Array(Array(3, 4), Array(15, 4)), TrailingMinusNumbers:=True
' Autofit the widths
.UsedRange.Columns.AutoFit

' Copy sheet to the new workbook
' .Copy

' Copy data to the destination range (updated 2018-09-11)
.UsedRange.Copy Workbooks(DestWorkbook).Worksheets(DestSheet).Cells(1, 1)
' Release (close) CsvFile
.Parent.Close False
End With
 
Upvote 0
this is the data provided in constants

DestWorkbook = Application.ActiveWorkbook.FullName
Const DestSheet = "NSEStocks"
Const DestCell = "I2"
 
Upvote 0
Don't use this constant then:
'Const DestWorkbook = ... <-- Comment this line

' And add the below lines instead
Dim DestWorkbook as String
DestWorkbook = ActiveWorkbook.Name
 
Last edited:
Upvote 0
It worked, thanks a lot ZVI. pitty on me :)

ZVI said:
Don't use this constant then:
'Const DestWorkbook = ... <-- Comment this line

' And add the below lines instead
Dim DestWorkbook as String
DestWorkbook = ActiveWorkbook.Name
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

H
  • Question
Macro to download zip, unpack and copy data
Replies
0
Views
81
HeinrichPaul
H
D
  • Question
Unzip latest file from Source path to destination path
Replies
5
Views
331
DSSD
D
B
  • Question
Download a file with progress possible?
Replies
8
Views
527
Dan_W
D
S
  • Question
Create Excel Packing Slips using CSV Data
Replies
4
Views
269
StaceyVECL
S
S
  • Question
download .csv file from web
Replies
3
Views
364
MyHanhCB
MyHanhCB

Forum statistics

Threads
1,214,932
Messages
6,122,332
Members
449,077
Latest member
jmsotelo

Share this page

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
Back
Top