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
