Need vba to download and copy the data from zip file

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
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
You must log in or register to reply here.

Similar threads

H
  • Question Question
Macro to download zip, unpack and copy data
Replies
0
Views
711
HeinrichPaul
H
D
  • Question Question
VBA Download URL and rename file
Replies
6
Views
287
Jeffrey Mahoney
Jeffrey Mahoney
D
  • Question Question
Embedded data from external links
Replies
2
Views
170
jkpieterse
jkpieterse
D
  • Question Question
Unzip latest file from Source path to destination path
Replies
5
Views
763
DSSD
D
W
  • Solved
Formula with Link not working in VBA
Replies
2
Views
236
woodsy74
W

Forum statistics

Threads
1,223,920
Messages
6,175,377
Members
452,638
Latest member
Oluwabukunmi

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