Skip to main content
1 of 2
StormsEdge
  • 589
  • 4
  • 12

Retrieves Data From Various Excel Sheets Online, sorts, edits, and Analyzes said Data

Thanks in advance! I'm fairly new to Excel VBA so I welcome all criticism and advice! 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 certain this part of stack is for code review, but if this is off topic please let me know and I will delete immediately. Thanks again.

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
StormsEdge
  • 589
  • 4
  • 12