Thema: Web-Aktienkursabfrage bei YAHOO

ClassModule: DieseArbeitsmappe

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars("Data").Controls("Yahoo").Delete
    On Error GoTo 0
End Sub

Private Sub Workbook_Open()
   Dim oBtn As CommandBarButton
   With Application.CommandBars("Data")
      On Error Resume Next
      .Controls("Yahoo").Delete
      On Error GoTo 0
      Set oBtn = .Controls.Add
   End With
   With oBtn
      .Caption = "Yahoo"
      .FaceId = 610
      .BeginGroup = True
      .OnAction = "Abruf"
    End With
End Sub

StandardModule: Modul1

Sub Abruf()
   Dim wks As Worksheet
   Dim var As Variant
   Dim sWkn As String, sQuery As String
   Application.ScreenUpdating = False
   Set wks = ActiveSheet
   sWkn = InputBox( _
      prompt:="WKN-Nr.:", _
      Title:="Web-Abfrage", _
      Default:="840400")
   If sWkn = "" Then Exit Sub
   sQuery = "http://de.finance.yahoo.com/q?m=*&s=" & sWkn & "&d=v1"
   Worksheets.Add after:=Worksheets(Worksheets.Count)
   With ActiveSheet.QueryTables.Add(Connection:= _
         "URL;" & sQuery, _
         Destination:=Range("A1"))
      .Refresh BackgroundQuery:=False
   End With
   var = Application.Match(sWkn & "*", Columns(1), 0)
   wks.Range("A2").Value = Cells(var, 2).Value
   wks.Range("B2").Value = Cells(var, 1).Value
   wks.Range("C2").Value = Cells(var, 3).Value
   wks.Range("D2").Value = Cells(var, 5).Value
   wks.Range("E2").Value = Cells(var, 6).Value
   wks.Range("F2").Value = Cells(var, 7).Value
   wks.Range("G2").Value = Cells(var, 8).Value
   wks.Range("H2").Value = Now
   Application.DisplayAlerts = False
   ActiveSheet.Delete
   Application.DisplayAlerts = True
   Worksheets("Daten").Select
   Range("A1").Select
   Columns("A:G").AutoFit
   Application.ScreenUpdating = True
End Sub

Beiträge aus dem Excel-Forum zu den Themen Allgemein und Internet