Jump to content
Mauri135

Importar cotizaciones desde una pagina web al Excel AUTOMATICAMENTE

Recommended Posts

Buenas a todos, estoy queriendo automatizar una tarea que vengo haciendo de manera manual, la cual es importar las cotizaciones de precios que me arroja diariamente una pagina web hacia mi plantilla de excel, obviamente lo quiero hacer de manera automática mediante una macro o lo que fuere.

En este caso seria importar la ultima cotizacion que me arroja esta pagina: https://www.investing.com/currencies/eur-usd-historical-data

Alguien sabe si es posible hacerlo, y cuales serian los procedimientos?

Un saludo y muchas gracias.

Share this post


Link to post
Share on other sites

Hola!

Quizás esto te sea de ayuda...

Sub test()
Workbooks.Open "https://www.investing.com/currencies/eur-usd-historical-data"

' Aqui va el codigo para extraer la última cotización
' Se puede observar que la tabla esta entre los textos: Download Data y My Sentiments, lo cual podria servir como
' referencia para la extracción del dato deseado
'
' Si se es mas confiado, se podría hacer la suposición que la última cotización estara en la fila 471.
End Sub

Con el codigo anterior podras abrir la pagina web directamente en Excel y ahí podrás grabar una macro para quedarte con el 

Saludos!

Share this post


Link to post
Share on other sites

Buenas @Mauri135

O puedes usar

Para solo el valor

Sub GetCurrenciesEUR_USD()
    Dim strUR   As String
    Dim strDV   As String
    Dim strTP   As String
    Dim obj     As Object
    Dim objDoc  As Object
    Dim objDV   As Object
    Dim objSP   As Object
    Dim objTP   As Object
    Dim dato    As String
    Dim strERR  As String
    strDV = "top bold inlineblock"
    strUR = "https://www.investing.com/currencies/eur-usd-historical-data"
    Set obj = CreateObject("WinHttp.winHttpRequest.5.1")
    With obj
        .Open "GET", strUR, False
        .Option(0) = 13056
        .Option(12) = "http-user-agent=Mozilla/5.0 (Windows NT 10.0; WOW64; rv:48.0) Gecko/20100101 Firefox/48.0"
        .Send
        If .Status = 200 Then
            Set objDoc = CreateObject("htmlfile")
            objDoc.Write .responseText
        Else
            strERR = .statustext
        End If
    End With
    Set obj = Nothing
    If Not objDoc Is Nothing Then
        Set objDV = objDoc.getElementsByTagName("div")
        If Not objDV Is Nothing Then
            For Each objTP In objDV
                strTP = ""
                On Error Resume Next
                strTP = objTP.className
                On Error GoTo 0
                If strTP = strDV Then
                    dato = objTP.innertext
                    Exit For
                End If
            Next
        Else
            strERR = "No se puede tener acceso"
        End If
        Set objDV = Nothing
    Else
        strERR = "No se puede tener acceso"
    End If
    Set objDoc = Nothing
    If strERR = "" Then
        MsgBox dato, vbInformation, Application.OrganizationName
    Else
        MsgBox strERR, vbExclamation, Application.OrganizationName
    End If
End Sub

O para todos los datos

Sub GetTableCurrenciesEUR_USD()
    Dim strUR   As String
    Dim strDV   As String
    Dim strTP   As String
    Dim obj     As Object
    Dim objDoc  As Object
    Dim objTB   As Object
    Dim objTP   As Object
    Dim objTH   As Object
    Dim objTR   As Object
    Dim objTD   As Object
    Dim dato    As String
    Dim datos()
    Dim c       As Long
    Dim i       As Long
    Dim n       As Long
    Dim u       As Long
    Dim ii      As Long
    Dim strERR  As String
    strTP = "curr_table"
    strUR = "https://www.investing.com/currencies/eur-usd-historical-data"
    Set obj = CreateObject("WinHttp.winHttpRequest.5.1")
    With obj
        .Open "GET", strUR, False
        .Option(0) = 13056
        .Option(12) = "http-user-agent=Mozilla/5.0 (Windows NT 10.0; WOW64; rv:48.0) Gecko/20100101 Firefox/48.0"
        .Send
        If .Status = 200 Then
            Set objDoc = CreateObject("htmlfile")
            objDoc.Write .responseText
        Else
            strERR = .statustext
        End If
    End With
    Set obj = Nothing
    If Not objDoc Is Nothing Then
        Set objTB = objDoc.getElementById(strTP)
        If Not objTB Is Nothing Then
            u = objTB.Rows.Length
            c = objTB.Rows(1).Cells.Length
            ReDim datos(1 To u, 1 To c)
            For Each objTR In objTB.Rows
                i = i + 1
                ii = 0
                For Each objTH In objTR.Cells
                    ii = ii + 1
                    dato = objTH.outerText
                    datos(i, ii) = dato
                Next
            Next
        Else
            strERR = "No se puede tener acceso"
        End If
        Set objTB = Nothing
    Else
        strERR = "No se puede tener acceso"
    End If
    Set objDoc = Nothing
    If strERR = "" Then
        Hoja1.Range("B3").Resize(u, c).Value = datos
        MsgBox "Finalizada la extración", vbInformation, Application.OrganizationName
    Else
        MsgBox strERR, vbExclamation, Application.OrganizationName
    End If
End Sub

Un saludo

Share this post


Link to post
Share on other sites
En 11/10/2017 at 19:40 , logroastur dijo:

Buenas @Mauri135

O puedes usar

Para solo el valor


Sub GetCurrenciesEUR_USD()
    Dim strUR   As String
    Dim strDV   As String
    Dim strTP   As String
    Dim obj     As Object
    Dim objDoc  As Object
    Dim objDV   As Object
    Dim objSP   As Object
    Dim objTP   As Object
    Dim dato    As String
    Dim strERR  As String
    strDV = "top bold inlineblock"
    strUR = "https://www.investing.com/currencies/eur-usd-historical-data"
    Set obj = CreateObject("WinHttp.winHttpRequest.5.1")
    With obj
        .Open "GET", strUR, False
        .Option(0) = 13056
        .Option(12) = "http-user-agent=Mozilla/5.0 (Windows NT 10.0; WOW64; rv:48.0) Gecko/20100101 Firefox/48.0"
        .Send
        If .Status = 200 Then
            Set objDoc = CreateObject("htmlfile")
            objDoc.Write .responseText
        Else
            strERR = .statustext
        End If
    End With
    Set obj = Nothing
    If Not objDoc Is Nothing Then
        Set objDV = objDoc.getElementsByTagName("div")
        If Not objDV Is Nothing Then
            For Each objTP In objDV
                strTP = ""
                On Error Resume Next
                strTP = objTP.className
                On Error GoTo 0
                If strTP = strDV Then
                    dato = objTP.innertext
                    Exit For
                End If
            Next
        Else
            strERR = "No se puede tener acceso"
        End If
        Set objDV = Nothing
    Else
        strERR = "No se puede tener acceso"
    End If
    Set objDoc = Nothing
    If strERR = "" Then
        MsgBox dato, vbInformation, Application.OrganizationName
    Else
        MsgBox strERR, vbExclamation, Application.OrganizationName
    End If
End Sub

O para todos los datos


Sub GetTableCurrenciesEUR_USD()
    Dim strUR   As String
    Dim strDV   As String
    Dim strTP   As String
    Dim obj     As Object
    Dim objDoc  As Object
    Dim objTB   As Object
    Dim objTP   As Object
    Dim objTH   As Object
    Dim objTR   As Object
    Dim objTD   As Object
    Dim dato    As String
    Dim datos()
    Dim c       As Long
    Dim i       As Long
    Dim n       As Long
    Dim u       As Long
    Dim ii      As Long
    Dim strERR  As String
    strTP = "curr_table"
    strUR = "https://www.investing.com/currencies/eur-usd-historical-data"
    Set obj = CreateObject("WinHttp.winHttpRequest.5.1")
    With obj
        .Open "GET", strUR, False
        .Option(0) = 13056
        .Option(12) = "http-user-agent=Mozilla/5.0 (Windows NT 10.0; WOW64; rv:48.0) Gecko/20100101 Firefox/48.0"
        .Send
        If .Status = 200 Then
            Set objDoc = CreateObject("htmlfile")
            objDoc.Write .responseText
        Else
            strERR = .statustext
        End If
    End With
    Set obj = Nothing
    If Not objDoc Is Nothing Then
        Set objTB = objDoc.getElementById(strTP)
        If Not objTB Is Nothing Then
            u = objTB.Rows.Length
            c = objTB.Rows(1).Cells.Length
            ReDim datos(1 To u, 1 To c)
            For Each objTR In objTB.Rows
                i = i + 1
                ii = 0
                For Each objTH In objTR.Cells
                    ii = ii + 1
                    dato = objTH.outerText
                    datos(i, ii) = dato
                Next
            Next
        Else
            strERR = "No se puede tener acceso"
        End If
        Set objTB = Nothing
    Else
        strERR = "No se puede tener acceso"
    End If
    Set objDoc = Nothing
    If strERR = "" Then
        Hoja1.Range("B3").Resize(u, c).Value = datos
        MsgBox "Finalizada la extración", vbInformation, Application.OrganizationName
    Else
        MsgBox strERR, vbExclamation, Application.OrganizationName
    End If
End Sub

Un saludo

Muchisimas gracias, va a la perfección, estare quemando neuronas para añadir algunos detalles, si no luego te envio mp jeje, Un saludo y gracias!

Share this post


Link to post
Share on other sites
Guest
This topic is now closed to further replies.



×
×
  • Create New...

Important Information

Privacy Policy


CTA Templates.png