This is a routine I wrote to streamline analysis I need to do that originally took 1.5 hours and now takes about 4 minutes total run time.
I'm fairly new to Excel VBA so I welcome all criticism and advice!
Option Explicit
#If VBA7 And Win64 Then
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As LongPtr, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As LongPtr, _
ByVal lpfnCB As LongPtr _
) As Long
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#Else
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" ( _
ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long _
) As Long
Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
Alias "DeleteUrlCacheEntryA" ( _
ByVal lpszUrlName As String _
) As Long
#End If
Public Const ERROR_SUCCESS As Long = 0
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000
Public Const csURL As String = "http://www.cmegroup.com/CmeWS/exp/voiProductDetailsViewExport.ctl?media=xls&tradeDate=×d×&reportType=P&productId=×p×"
Sub Pull_CME_Data()
Dim getBook As String, OiProductCodesArray() As String
Dim cmeDataBook As Workbook
Dim data As Worksheet, controlPanel As Worksheet, lo As Worksheet, wa As Worksheet, sevenA As Worksheet, oh As Worksheet, at As Worksheet, ob As Worksheet, ra As Worksheet, cvr As Worksheet, ln As Worksheet, wtioi As Worksheet, rboboi As Worksheet, ethanoloi As Worksheet, heatoi As Worksheet, sevenaoi As Worksheet, waoi As Worksheet, ngoi As Worksheet, atoi As Worksheet, raoi As Worksheet, volumeSheet As Worksheet
Dim ClearWshtsArray As Variant, OiWshtsArray As Variant
Dim WshtNameCrnt As Variant, OiWshtsCrnt As Variant
Dim oiProductCodesArrayCounter As Integer
'Initial declarations and setup
getBook = ActiveWorkbook.Name
Set cmeDataBook = Workbooks(getBook)
Set data = cmeDataBook.Sheets("Data")
Set controlPanel = cmeDataBook.Sheets("Control Panel")
Set lo = cmeDataBook.Sheets("Lo")
Set wa = cmeDataBook.Sheets("Wa")
Set sevenA = cmeDataBook.Sheets("7A")
Set oh = cmeDataBook.Sheets("oh")
Set at = cmeDataBook.Sheets("at")
Set ob = cmeDataBook.Sheets("Ob")
Set ra = cmeDataBook.Sheets("Ra")
Set cvr = cmeDataBook.Sheets("CVR")
Set ln = cmeDataBook.Sheets("Ln")
Set wtioi = cmeDataBook.Sheets("WtiOI")
Set rboboi = cmeDataBook.Sheets("RbobOI")
Set ethanoloi = cmeDataBook.Sheets("EthanolOI")
Set heatoi = cmeDataBook.Sheets("HeatOI")
Set sevenaoi = cmeDataBook.Sheets("7AOI")
Set waoi = cmeDataBook.Sheets("WAOI")
Set ngoi = cmeDataBook.Sheets("NGOI")
Set atoi = cmeDataBook.Sheets("ATOI")
Set raoi = cmeDataBook.Sheets("RAOI")
Set volumeSheet = cmeDataBook.Sheets("Total Volume By Product (CME)")
'Sets three arrays for iteration through different sheets
ClearWshtsArray = Array(data.Name, lo.Name, wa.Name, sevenA.Name, oh.Name, at.Name, ob.Name, ra.Name, _
cvr.Name, ln.Name, wtioi.Name, rboboi.Name, ethanoloi.Name, heatoi.Name, sevenaoi.Name, waoi.Name, _
raoi.Name)
OiWshtsArray = Array(wtioi.Name, rboboi.Name, ethanoloi.Name, heatoi.Name, sevenaoi.Name, waoi.Name, ngoi.Name, atoi.Name, raoi.Name)
OiProductCodesArray() = Split(controlPanel.Cells(4, 13).Value2, "or")
On Error GoTo bailOut
'Preparation for execution
Application.ScreenUpdating = False
Application.StatusBar = True
'Clears data sheets of anything prior
For Each WshtNameCrnt In ClearWshtsArray
Worksheets(WshtNameCrnt).Activate
With Worksheets(WshtNameCrnt)
.UsedRange.Clear
End With
Next WshtNameCrnt
Call GetTotalVolumeData(volumeSheet, controlPanel)
'For CSV data file
controlPanel.Activate
Cells(2, 1).Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Workbooks.Open Filename:="ftp://ftp.cmegroup.com/pub/settle/nymex_option.csv"
Windows("nymex_option.csv").Visible = True
'Copies data and transfers to data tab
Cells.Select
Selection.Copy
data.Activate
With data
.Cells(1, 1).Select
.Paste
.Cells(1, 1).Select
End With
'Clears clipboard and closes CSV file to avoid potential contamination
Application.CutCopyMode = False
Windows("nymex_option.csv").Activate
Application.DisplayAlerts = False
Workbooks("nymex_option.csv").Close
'Brings OI data by product
For oiProductCodesArrayCounter = 0 To UBound(OiProductCodesArray)
Call GetOiData(OiProductCodesArray(oiProductCodesArrayCounter), Sheets(OiWshtsArray(oiProductCodesArrayCounter)), controlPanel)
Next oiProductCodesArrayCounter
'Gets Lo Data sorted and cleaned
Call seperateData(cmeDataBook, data, lo, "lo", 1500)
'Get WA data, format and paste
Call seperateData(cmeDataBook, data, wa, "wa", 100)
'Get 7A data, format and paste
Call seperateData(cmeDataBook, data, sevenA, "7a", 100)
'Get OH data, format and paste
Call seperateData(cmeDataBook, data, oh, "oh", 100)
'Get AT data, format and paste
Call seperateData(cmeDataBook, data, at, "at", 5)
'Get OB data, format and paste
Call seperateData(cmeDataBook, data, ob, "ob", 100)
'Get RA data, format and paste
Call seperateData(cmeDataBook, data, ra, "ra", 5)
'Get Ethanol Data, format and paste
Call seperateData(cmeDataBook, data, cvr, "cvr", 5)
'Get Ln Data, format and paste
Call seperateData(cmeDataBook, data, ln, "ln", 1000)
'Excel standard function cleanup
Application.ScreenUpdating = True
Application.StatusBar = False
data.Activate
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter
controlPanel.Activate
MsgBox ("Data dump file successfully pulled and analyzed")
Exit Sub
'Error handler for routine wide errors
bailOut:
Application.ScreenUpdating = True
Application.StatusBar = False
controlPanel.Activate
MsgBox ("Data dump file has failed. Please check hyperlink, sheet names, date, and try again.")
End Sub
Sub GetTotalVolumeData(volumeSheet As Worksheet, controlSheet As Worksheet)
Dim getBook As String, energy As String
Dim newDataBook As Workbook
Dim newDataSheet As Worksheet
Dim lRow As Long, dataBookLRow As Long
Dim ProductCodes() As String
Dim counter As Integer
'Sets string variables and array
energy = "Energy"
ProductCodes() = Split(controlSheet.Cells(2, 17).Value2, "or")
Workbooks.Open Filename:=controlSheet.Cells(2, 8)
getBook = ActiveWorkbook.Name
'Set workbook name
Set newDataBook = Workbooks(getBook)
Set newDataSheet = newDataBook.Sheets(1)
dataBookLRow = newDataSheet.Cells(newDataSheet.Rows.Count, "A").End(xlUp).Row
For counter = 0 To UBound(ProductCodes)
'Counter iterating over the array to capture all the products
Call ProcessVolumeData(volumeSheet, ProductCodes(counter), newDataBook, dataBookLRow, controlSheet)
Next
Application.DisplayAlerts = False
newDataBook.Close
Application.DisplayAlerts = True
End Sub
Sub ProcessVolumeData(volumeSheet As Worksheet, product As String, newDataBook As Workbook, dataBookLRow As Long, controlSheet As Worksheet)
Dim lRow As Long
'Finds lRow of Volume Sheet
lRow = volumeSheet.Cells(volumeSheet.Rows.Count, "B").End(xlUp).Row
newDataBook.Activate
'WTI American
With newDataBook.Sheets(1)
Cells(5, 1).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter
Selection.AutoFilter Field:=6, Criteria1:="=" & "Energy"
Selection.AutoFilter Field:=1, Criteria1:="=" & Trim(product)
Range("A6:M" & dataBookLRow).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
End With
volumeSheet.Activate
With volumeSheet
.Cells((lRow + 1), 2).Select
.Paste
.Cells((lRow + 1), 2).Select
.Cells((lRow + 1), 1) = controlSheet.Cells(1, 5).Value
End With
End Sub
Private Function seperateData(cmeDataBook As Workbook, data As Worksheet, productSheet As Worksheet, product As String, minimumVal As Integer)
'Finds product code in data table, formats it, and pastes into the relevant sheet
Dim rownum As Integer
Dim lRow As Integer
Dim counter As Integer
Dim contract As String
Dim productOiSheet As Worksheet
data.Activate
Cells(1, 1).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter
Selection.AutoFilter Field:=1, Criteria1:="=" & product
Selection.AutoFilter Field:=18, Criteria1:=">=" & minimumVal
Cells(1, 1).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
productSheet.Activate
With productSheet
.Cells(1, 1).Select
.Paste
.Cells(1, 1).Select
End With
Application.CutCopyMode = False
Selection.Sort Key1:=Range("R2"), Order1:=xlDescending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'Prevents unecessary formatting of empty cells
If IsEmpty(Cells(2, 1)) = True Then
GoTo Skip
End If
'finds last row and sets row number
lRow = productSheet.Cells(productSheet.Rows.Count, "A").End(xlUp).Row
rownum = 2
'Pastes Product Symbol into second column header and deletes first column
productSheet.Cells(1, 2) = productSheet.Cells(2, 1)
'Builds product code
For counter = rownum To lRow
Select Case productSheet.Cells(counter, 2)
Case 1
productSheet.Cells(counter, 2) = "F" & Right(productSheet.Cells(counter, 3), 2)
Case 2
productSheet.Cells(counter, 2) = "G" & Right(productSheet.Cells(counter, 3), 2)
Case 3
productSheet.Cells(counter, 2) = "H" & Right(productSheet.Cells(counter, 3), 2)
Case 4
productSheet.Cells(counter, 2) = "J" & Right(productSheet.Cells(counter, 3), 2)
Case 5
productSheet.Cells(counter, 2) = "K" & Right(productSheet.Cells(counter, 3), 2)
Case 6
productSheet.Cells(counter, 2) = "M" & Right(productSheet.Cells(counter, 3), 2)
Case 7
productSheet.Cells(counter, 2) = "N" & Right(productSheet.Cells(counter, 3), 2)
Case 8
productSheet.Cells(counter, 2) = "Q" & Right(productSheet.Cells(counter, 3), 2)
Case 9
productSheet.Cells(counter, 2) = "U" & Right(productSheet.Cells(counter, 3), 2)
Case 10
productSheet.Cells(counter, 2) = "V" & Right(productSheet.Cells(counter, 3), 2)
Case 11
productSheet.Cells(counter, 2) = "X" & Right(productSheet.Cells(counter, 3), 2)
Case 12
productSheet.Cells(counter, 2) = "Z" & Right(productSheet.Cells(counter, 3), 2)
End Select
Next
'changes C and P to puts
For counter = rownum To lRow
Select Case productSheet.Cells(counter, 5)
Case "P"
productSheet.Cells(counter, 5) = "PUT"
Case "C"
productSheet.Cells(counter, 5) = "CALL"
End Select
Next
'General formatting for each analyzed sheet
Columns("C:D").Select
Selection.Delete Shift:=xlToLeft
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Columns("E:L").Select
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Columns("H:J").Select
Selection.Delete Shift:=xlToLeft
productSheet.Cells(1, 8) = "OI"
productSheet.Cells(1, 9) = "Chg In OI"
Select Case Cells(1, 1)
Case "LO"
Set productOiSheet = cmeDataBook.Sheets("WtiOI")
Case "WA"
Set productOiSheet = cmeDataBook.Sheets("WAOI")
Case "7A"
Set productOiSheet = cmeDataBook.Sheets("7AOI")
Case "OH"
Set productOiSheet = cmeDataBook.Sheets("HeatOI")
Case "AT"
Set productOiSheet = cmeDataBook.Sheets("ATOI")
Case "OB"
Set productOiSheet = cmeDataBook.Sheets("RbobOI")
Case "RA"
Set productOiSheet = cmeDataBook.Sheets("RAOI")
Case "CVR"
Set productOiSheet = cmeDataBook.Sheets("EthanolOI")
Case "LN"
Set productOiSheet = cmeDataBook.Sheets("NGOI")
End Select
Range("C2:C" & lRow).NumberFormat = "###.00"
Call AnalyzeOiData(lRow, productOiSheet, productSheet, rownum)
Columns("A:i").EntireColumn.AutoFit
Range("A1:i1").Select
Selection.Font.Bold = True
Range(Selection, Selection.End(xlDown)).Select
With Selection
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveWindow.SmallScroll Down:=-6
productSheet.Select
Rows("1:1").RowHeight = 42
Rows("1:1").RowHeight = 26.25
Rows("1:1").RowHeight = 39.75
'Skips formatting practices for products that did not fit the value minimum
Skip:
'Do nothing skip formatting
End Function
Sub FormatData(dataT As Worksheet)
'Formats Data T
Dim rownum As Integer
Dim lRow As Integer
Dim counter As Integer
dataT.Activate
'finds last row and sets row number
lRow = dataT.Cells(dataT.Rows.Count, "A").End(xlUp).Row
rownum = 2
For counter = rownum To lRow
Select Case dataT.Cells(counter, 2)
Case 1
dataT.Cells(counter, 2) = "F" & Right(dataT.Cells(counter, 3), 2)
Case 2
dataT.Cells(counter, 2) = "G" & Right(dataT.Cells(counter, 3), 2)
Case 3
dataT.Cells(counter, 2) = "H" & Right(dataT.Cells(counter, 3), 2)
Case 4
dataT.Cells(counter, 2) = "J" & Right(dataT.Cells(counter, 3), 2)
Case 5
dataT.Cells(counter, 2) = "K" & Right(dataT.Cells(counter, 3), 2)
Case 6
dataT.Cells(counter, 2) = "M" & Right(dataT.Cells(counter, 3), 2)
Case 7
dataT.Cells(counter, 2) = "N" & Right(dataT.Cells(counter, 3), 2)
Case 8
dataT.Cells(counter, 2) = "Q" & Right(dataT.Cells(counter, 3), 2)
Case 9
dataT.Cells(counter, 2) = "U" & Right(dataT.Cells(counter, 3), 2)
Case 10
dataT.Cells(counter, 2) = "V" & Right(dataT.Cells(counter, 3), 2)
Case 11
dataT.Cells(counter, 2) = "X" & Right(dataT.Cells(counter, 3), 2)
Case 12
dataT.Cells(counter, 2) = "Z" & Right(dataT.Cells(counter, 3), 2)
End Select
Next
'changes C and P to puts
For counter = rownum To lRow
Select Case dataT.Cells(counter, 5)
Case "P"
dataT.Cells(counter, 5) = "PUT"
Case "C"
dataT.Cells(counter, 5) = "CALL"
End Select
Next
'Formats strikes and basic formatting
dataT.Range("F2:F" & lRow).NumberFormat = "###.00"
dataT.Columns("H:O").Select
Selection.Delete Shift:=xlToLeft
dataT.Columns("T:T").Select
Selection.Delete Shift:=xlToLeft
dataT.Columns("C:D").Select
Selection.Delete Shift:=xlToLeft
End Sub
Sub GetOiData(productID As String, targetSheet As Worksheet, controlPanel As Worksheet)
'Function access OI data from the CME website and copies it into the book for all products
Dim filePath As String
Dim reportDate As String
Dim w As Long, ret As Long, sWAN As String, sLAN As String, sNAM As String
Application.DisplayAlerts = False
reportDate = Format(controlPanel.Cells(1, 5).Value, "yyyymmdd")
'sets potential file name and environTMP
sNAM = Format(controlPanel.Cells(1, 5).Value, "\C\M\E\_OIL\_yyyymmdd")
sLAN = Environ("TMP") & Chr(92) & Format(controlPanel.Cells(1, 5).Value, "\C\M\E\_OIL\_yyyymmdd.xl\s")
'Testing for error sLAN
If CBool(Len(Dir(sLAN, vbNormal))) Then Kill sLAN
sWAN = Replace(Replace(csURL, _
"×d×", Format(controlPanel.Cells(1, 5).Value, "yyyymmdd")), _
"×p×", productID)
ret = URLDownloadToFile(0&, sWAN, sLAN, BINDF_GETNEWESTVERSION, 0&)
If ret = ERROR_SUCCESS Then
With Workbooks.Open(Filename:=sLAN, ReadOnly:=True)
.Worksheets(1).Name = sNAM
.Worksheets(1).UsedRange.Select
Selection.Copy
targetSheet.Activate
With targetSheet
.Cells(1, 1).Select
.Paste
End With
.Worksheets(sNAM).Activate
.Close savechanges:=False
End With
Kill sLAN
Else
If CBool(Err.Number) Then
MsgBox (Err.Number & ": " & Err.Description)
Else
MsgBox ("Unable to download the file")
End If
Err.Clear
End If
End Sub
Sub AnalyzeOiData(lRow As Integer, oiDataSheet As Worksheet, productSheet As Worksheet, rownum As Integer)
Dim counter As Integer
Dim monthExp As String
Dim oiLocationFinder As Range
Dim strikeRan As Range
Dim optStrike As Long
Dim locStor As Integer
Dim strikeLoc As Range
Dim emptyCounter As Integer
Dim continue As Boolean
For counter = rownum To lRow
continue = True
'Returns formatted monthcode for finding the different months of expiry embedded in the OI data
monthExp = GetMonthCode(productSheet.Cells(counter, 1), productSheet.Cells(counter, 2))
'multiplies the strike by 100 in an attempt to match the format in the OI sheet
If productSheet.Cells(1, 1) = "OH" Or productSheet.Cells(1, 1) = "AT" Or productSheet.Cells(1, 1) = "OB" Then
optStrike = productSheet.Cells(counter, 3).Value * 10000
ElseIf productSheet.Cells(1, 1) = "LN" Then
optStrike = productSheet.Cells(counter, 3).Value * 1000
Else
optStrike = productSheet.Cells(counter, 3).Value * 100
End If
'Sets OI finder in order to access Row data
Set oiLocationFinder = oiDataSheet.Columns(1).Find(monthExp)
locStor = oiLocationFinder.Row
oiDataSheet.Activate
Cells(locStor, 1).Select
emptyCounter = locStor
Do
DoEvents
If Cells(emptyCounter, 1) = optStrike Then
continue = False
Set strikeLoc = Range("A" & emptyCounter)
ElseIf IsEmpty(Cells(emptyCounter, 1)) = True Then
continue = False
Else
emptyCounter = emptyCounter + 1
End If
Loop Until continue = False
If strikeLoc Is Nothing Then
GoTo Skip
End If
locStor = strikeLoc.Row
productSheet.Cells(counter, 8) = oiDataSheet.Cells(locStor, 9)
productSheet.Cells(counter, 9) = oiDataSheet.Cells(locStor, 10)
Skip:
If IsEmpty(productSheet.Cells(counter, 8)) = True And IsEmpty(productSheet.Cells(counter, 9)) = True Then
productSheet.Cells(counter, 8) = "NA"
productSheet.Cells(counter, 9) = "NA"
End If
Set oiLocationFinder = Nothing
Next
End Sub
Function GetMonthCode(exp As String, optionType As String) As String
'Formats month code so that it is readable and can be located in OI tables
Dim monthYear As String
Dim year As Integer
year = Right(exp, 2)
Select Case exp
Case "F" & year
monthYear = "JAN" & " " & Right(exp, 2) & " "
Case "G" & year
monthYear = "FEB" & " " & Right(exp, 2) & " "
Case "H" & year
monthYear = "MAR" & " " & Right(exp, 2) & " "
Case "J" & year
monthYear = "APR" & " " & Right(exp, 2) & " "
Case "K" & year
monthYear = "MAY" & " " & Right(exp, 2) & " "
Case "M" & year
monthYear = "JUN" & " " & Right(exp, 2) & " "
Case "N" & year
monthYear = "JUL" & " " & Right(exp, 2) & " "
Case "Q" & year
monthYear = "AUG" & " " & Right(exp, 2) & " "
Case "U" & year
monthYear = "SEP" & " " & Right(exp, 2) & " "
Case "V" & year
monthYear = "OCT" & " " & Right(exp, 2) & " "
Case "X" & year
monthYear = "NOV" & " " & Right(exp, 2) & " "
Case "Z" & year
monthYear = "DEC" & " " & Right(exp, 2) & " "
End Select
'Call/Put designation
If optionType = "CALL" Then
GetMonthCode = monthYear & "Calls"
ElseIf optionType = "PUT" Then
GetMonthCode = monthYear & "Puts"
End If
End Function
#If
in VBA, I had to look it up. \$\endgroup\$