Last active
May 23, 2022 22:07
-
-
Save capm/4be0a99d5e29a19581715bf970d5c4e7 to your computer and use it in GitHub Desktop.
Code to download data from mutual funds from the SMV website.
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Sub ValorCuota() | |
' | |
' ValorCuota Macro | |
' | |
' Turn off all features | |
'BestPractices (0) | |
' Declare variables | |
' Workbooks and worksheets | |
Dim wbRaw As Workbook | |
Dim wsRaw As Worksheet, wsFX As Worksheet, wsFinal As Worksheet, wsLists As Worksheet | |
' Dates | |
' Ranges | |
Dim rngDates As Range | |
' Strings | |
Dim urlBase As String, urlScrap As String | |
Dim arg1 As String, arg2 As String | |
Dim val1 As String, val2 As String | |
' Integers | |
Dim iTmpRow As Integer, iTmpCol As Integer | |
' Set environment variables | |
' Create temp sheet to download data | |
Set wbRaw = ActiveWorkbook | |
' Set sheets | |
Set wsFX = wbRaw.Sheets("USDPEN") | |
Set wsLists = wbRaw.Sheets("Lists") | |
Set wsFinal = wbRaw.Sheets("Historic") | |
' Set url and arguments | |
urlBase = "http://www.smv.gob.pe/Frm_ValorCuotaDetalle_V2.aspx" | |
arg1 = "in_ac_pre_ope" | |
arg2 = "in_ad_fecha" | |
' Set argument values | |
val1 = "O" | |
'val2 = "06/02/2019" | |
For Each rngDates In wsLists.Range("B231:B235") | |
val2 = rngDates.Value | |
GoTo Line1 | |
Line2: | |
If rngDates Is Nothing Then Exit Sub | |
Next rngDates | |
' XXXXXXXXXXXXXXXXXXXXXXXXXXXXXX | |
Line1: | |
' Set url to scrap | |
urlScrap = urlBase & "?" & arg1 & "=" & val1 & "&" & arg2 & "=" & val2 | |
' Get FM table | |
Dim htmlSMV As HTMLDocument | |
Set htmlSMV = New HTMLDocument | |
htmlSMV.body.innerHTML = GetRawHTML(urlScrap) | |
' Read data | |
Dim tableFM As HTMLTable | |
Set tableFM = htmlSMV.getElementById("grdValorCuota") | |
' Copy data to temp sheet | |
Set wsRaw = AddSheet("Temp", wbRaw) | |
' Paste table | |
Call PasteHTMLTable(tableFM, wsRaw) | |
' Delete unused columns | |
With wsRaw | |
.Range("F:K,M:M,O:O").EntireColumn.Delete | |
.Activate | |
.Range("A1").Select | |
End With | |
' Copy exchange rate | |
' Find cell | |
Dim rFind As Range | |
Set rFind = FindLastCellIndexVal(wsRaw, "TIPO DE CAMBIO", 1) | |
' Paste dates and values | |
Call CopyTableTo(wsRaw, wsFX, 2, rFind) | |
wsFX.Cells(FindLastCell(wsFX, 1, 0), 1) = DateSerial(Year(val2), Month(val2), Day(val2)) | |
' Find last row with data for mutual funds | |
With wsRaw | |
.Activate | |
Set rFind = .Cells.Find("IGBVL", LookAt:=xlPart) | |
.Rows(rFind.Row & ":" & .Rows.Count).Delete | |
.Rows(1 & ":" & 2).Delete | |
.Columns(1).Insert Shift:=xlToRight | |
.Columns(3).Insert Shift:=xlToRight | |
.Activate | |
.Range("A1").Select | |
End With | |
' Detect fund class and add it left to the name | |
Dim tmpCell As Range | |
For Each tmpCell In wsRaw.Range(wsRaw.Cells(1, 2), wsRaw.Cells(FindLastCell(wsRaw, 2, 0), 2)) | |
' In range detect if cell is class name, if so move it left | |
If IsNumeric(Left(tmpCell.Value, 2)) = True And Mid(tmpCell.Value, 3, 3) = " - " Then | |
wsRaw.Cells(tmpCell.Row + 1, 1).Value = tmpCell.Value | |
End If | |
' Remove admin name from fund name | |
If InStr(tmpCell, wsRaw.Cells(tmpCell.Row, 4)) > 0 Or InStr(tmpCell, wsRaw.Cells(tmpCell.Row, 4) & "-") > 0 Then | |
' Fund name with format "ADMINNAME-FUNDNAME" | |
tmpCell = Replace(tmpCell, wsRaw.Cells(tmpCell.Row, 4) & "-", "") | |
tmpCell = Replace(tmpCell, wsRaw.Cells(tmpCell.Row, 4), "") | |
End If | |
' Fund series | |
If InStr(tmpCell, "SERIE ") > 0 Then | |
wsRaw.Cells(tmpCell.Row, 3).Value = Right(tmpCell, Len(tmpCell) - InStr(tmpCell, "SERIE ") + 1) | |
tmpCell = Replace(tmpCell, wsRaw.Cells(tmpCell.Row, 3), "") | |
' Fix AUM for funds with series | |
'If tmpCell = wsRaw.Cells(tmpCell.Row - 1, tmpCell.Column) And IsEmpty(wsRaw.Cells(tmpCell.Row, 8)) Then | |
' wsRaw.Cells(tmpCell.Row, 8).Value = wsRaw.Cells(tmpCell.Row - 1, 8).Value | |
'End If | |
Else: | |
wsRaw.Cells(tmpCell.Row, 3).Value = "UNICA" | |
End If | |
Next tmpCell | |
' Table transformations | |
With wsRaw | |
' Delete empty rows and add fund series column | |
.Columns(4).SpecialCells(xlCellTypeBlanks).EntireRow.Delete | |
' Delete repeated funds (from series funds). | |
'With .Columns(7) | |
' ' Change zeros to empty | |
' .Replace What:="0", Replacement:="", LookAt:=xlWhole | |
' .SpecialCells(xlCellTypeBlanks).EntireRow.Delete | |
'End With | |
' Add date column to the left | |
.Columns(1).Insert Shift:=xlToRight | |
.Range(.Cells(1, 1), .Cells(FindLastCell(wsRaw, 2, 0), 1)) = DateSerial(Year(val2), Month(val2), Day(val2)) | |
End With | |
' Fill blank lines left by fund classes | |
wsRaw.Range(Cells(1, 2), Cells(FindLastCell(wsRaw, 4, 0), 2)).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C" | |
' Copy final values to historic sheet | |
Call CopyTableTo(wsRaw, wsFinal, 1) | |
' Delete temp data | |
wsRaw.Delete | |
GoTo Line2 | |
' Turn on all features | |
'BestPractices (1) | |
End Sub | |
Public Function AddSheet(strName As String, Optional wbOrig As Workbook) As Worksheet | |
' | |
' | |
' | |
' Check if argument has value or its null | |
If wbOrig Is Nothing Then Set wbOrig = ThisWorkbook | |
On Error Resume Next | |
' Check if worksheet exists | |
For Each Worksheet In wbOrig.Worksheets | |
If strName = Worksheet.Name Then Worksheet.Delete | |
Next Worksheet | |
' If it doesn't exists create it and name it | |
With wbOrig | |
.Activate | |
Set AddSheet = .Sheets.Add(After:=.Sheets(.Sheets.Count)) | |
AddSheet.Name = strName | |
End With | |
End Function | |
Public Function PasteHTMLTable(tblRaw As HTMLTable, wsDes As Worksheet) | |
' | |
' | |
' | |
' | |
' Paste table | |
Dim clipboard As MSForms.DataObject | |
Set clipboard = New MSForms.DataObject | |
clipboard.SetText tblRaw.outerHTML | |
clipboard.PutInClipboard | |
wsDes.Activate | |
wsDes.Cells(1, 1).Select | |
wsDes.Paste | |
' Clean table | |
wsDes.Cells.ClearFormats | |
End Function | |
Public Function CopyTableTo(wsOr As Worksheet, wsDes As Worksheet, StartCol As Integer, Optional rngCopy As Range) | |
' Declare private variables | |
' If there is a range copy range if not determine table boundaries and copy table | |
If Not rngCopy Is Nothing Then | |
wsDes.Range(wsDes.Cells(FindLastCell(wsDes, 1, 0) + 1, StartCol), wsDes.Cells(FindLastCell(wsDes, 1, 0) + rngCopy.Rows.Count, rngCopy.Columns.Count)).Value = rngCopy.Value | |
Else | |
' Determine origin sheet table boundaries | |
Set rngCopy = wsOr.Range(wsOr.Cells(1, 1), wsOr.Cells(FindLastCell(wsOr, 1, 0), FindLastCell(wsOr, 1, 1))) | |
' Copy and paste table | |
wsDes.Range(wsDes.Cells(FindLastCell(wsDes, 1, 0) + 1, StartCol), wsDes.Cells(FindLastCell(wsDes, 1, 0) + rngCopy.Rows.Count, rngCopy.Columns.Count)).Value = rngCopy.Value | |
End If | |
End Function | |
Public Function FindLastCellIndexVal(wsEval As Worksheet, strName As String, IndexLoc As Integer) As Range | |
' Function to find last cell in the row (IndexLoc = 1) or column (IndexLoc = 0) if "srtName" in one cell. | |
' IndexLoc: "0" or "1" | |
' 0: Find last row in column | |
' 1: Find last column in row | |
' Find string in sheet | |
With wsEval.Cells | |
Set FindLastCellIndexVal = .Find(strName, LookAt:=xlPart) | |
End With | |
' Find last row of a range with "strName" as index | |
If IndexLoc = 0 Then | |
Set FindLastCellIndexVal = wsEval.Cells(FindLastCell(wsEval, FindLastCellIndexVal.Column, IndexLoc), FindLastCellIndexVal.Column) | |
End If | |
' Find last column of a range with "strname" as header | |
If IndexLoc = 1 Then | |
Set FindLastCellIndexVal = wsEval.Cells(FindLastCellIndexVal.Row, FindLastCell(wsEval, FindLastCellIndexVal.Row, IndexLoc)) | |
End If | |
End Function | |
Public Function FindLastCell(wsEval As Worksheet, wsCol As Integer, fType As Integer) As Long | |
' wsCol: Row or column number. | |
' fType can be 0 or 1. | |
' 0: Find last row in column | |
' 1: Find last column in row | |
' | |
If fType = 0 Then | |
FindLastCell = wsEval.Cells(wsEval.Rows.Count, wsCol).End(xlUp).Row | |
End If | |
If fType = 1 Then | |
FindLastCell = wsEval.Cells(wsCol, wsEval.Columns.Count).End(xlToLeft).Column | |
End If | |
If fType <> 0 And fType <> 1 Then | |
MsgBox "Must choose find last row in column or find last column in row." | |
End If | |
End Function | |
Public Function GetRawHTML(urlWebSite As String) | |
' | |
Set GetRawHTML = New HTMLDocument | |
With CreateObject("WINHTTP.WinHTTPRequest.5.1") | |
.Open "GET", urlWebSite, False | |
.send | |
GetRawHTML = .responseText | |
End With | |
' First select "Microsoft HTML Object Library" from VBA References | |
' Use it this way: | |
' Dim oHtml as HTMLDocument | |
' Set oHtml = New HTMLDocument | |
' oHtml.body.innerHTML = GetRawHTML(urlWebSite) | |
End Function | |
Public Function BestPractices(Indicator As Integer) | |
' Indicator must be 0 or 1, "0" to turn off and "1" to turn back to normal. | |
If Indicator = 0 Then | |
' Turn off some Excel functionality so your code runs faster | |
Application.ScreenUpdating = False | |
Application.DisplayStatusBar = False | |
Application.Calculation = xlCalculationManual | |
Application.EnableEvents = False | |
Application.DisplayAlerts = False | |
ActiveSheet.DisplayPageBreaks = False 'note this is a sheet-level setting | |
End If | |
If Indicator = 1 Then | |
' Restore state | |
Application.ScreenUpdating = True | |
Application.DisplayStatusBar = True | |
Application.Calculation = xlNormal | |
Application.EnableEvents = True | |
ActiveSheet.DisplayPageBreaks = True ' Note this is a sheet-level setting | |
Application.DisplayAlerts = True | |
End If | |
If Indicator <> 0 And Indicator <> 1 Then | |
MsgBox "Must choose between 0 and 1." | |
End If | |
End Function |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment