实时共享价格更新

Question

我一直在整理这个小程序，以根据用户输入的公司代码从Google财经中提取实时股价。然而，我定义的第一个函数（在顶部）只适用于AAPL，而不适用于任何其他公司代码，第二个函数（查找价格）在第32行中有一个对象定义的错误。我很新VBA（只使用它4天）。任何想法我做错了什么？

Function ExtractCID(fcid As String) As Integer 
    Dim i As Integer, iCount As Integer 
    Dim sText As String 
    Dim lNum As String 

    sText = fcid 

    For iCount = Len(sText) To 1 Step -1 
     If IsNumeric(Mid(sText, iCount, 1)) Then 
      i = i + 1 
      lNum = Mid(sText, iCount, 1) & lNum 
     End If 

     If i = 1 Then lNum = CInt(Mid(lNum, 1, 1)) 
    Next iCount 

    ExtractCID = CInt(lNum) 
End Function 

Public Function TakePrice(fpri As String) As Single 
    Dim s As String, i As Integer 
    Dim fprice As String 
    fprice = fpri 

    For i = 1 To Len(fprice) 
     If IsNumeric(Mid(fprice, i, 1)) Then 
      Exit For 
     End If 
    Next i 

    s = Mid(fprice, i, InStr(fprice, "</") - 1) 
    TakePrice = Convert.ToSingle(s) 
End Function 

Sub Shares() 
    Dim EPIC As String 
    Dim fprice As String 
    Dim sPrice As Single 
    Dim pPrice As Single 
    Dim Shares As Integer 
    Dim Change As Single 
    Dim Cost As Single 
    Dim MktVl As Single 
    Dim LG As Single 
    Dim L As Single 
    Dim url As String 
    Dim StartNumber As Integer 
    Dim EndNumber As Integer 
    Dim x As String 
    Dim cid As Integer 
    Dim fcid As String 

    EndNumber = Application.CountA(Range("A:A")) 
    For StartNumber = 2 To EndNumber 
     Sheet2.Cells(StartNumber, 1).Activate 
     EPIC = ActiveCell.Value 
     url = "http://www.google.com/finance?q=" & EPIC 
    With CreateObject("msxml2.xmlhttp") 
     .Open "GET", url, False 
     .send 
     x = .ResponseText 
    End With 
    fcid = (Mid(x, InStr(1, x, "cid="), 15)) 
    cid = ExtractCID(fcid) 
    Range("B4").Value = cid 
    fprice = Mid(x, InStr(1, x, cid & "_l") + Len(cid) + 3, 15) 
    sPrice = TakePrice(fprice) 
    ActiveCell.Offset(0, 1).Value = sPrice 
    pPrice = ActiveCell.Offset(0, 2).Value 
    Shares = ActiveCell.Offset(0, 3).Value 
    Cost = pPrice * Shares 
    ActiveCell.Offset(0, 4).Value = Cost 
    ActiveCell.Offset(0, 5).Value = ((sPrice - pPrice)/pPrice) * 100 
    MktVl = sPrice * Shares 
    ActiveCell.Offset(0, 6).Value = MktVl 
    ActiveCell.Offset(0, 7).Value = MktVl - Cost 
    L = ((MktVl - Cost)/Cost) * 100 
    ActiveCell.Offset(0, 8).Value = L 
    If L < 0 Then 
     ActiveCell.Offset(0, 8).Interior.Color = RGB(255, 0, 0) 
    Else 
     ActiveCell.Offset(0, 8).Interior.ColorIndex = xlNone 
    End If 
    Next StartNumber 
End Sub 

Answer 1

在TakePrice功能改变线：

s = Mid(fprice, i, InStr(fprice, "</") - 1) 

到

s = Mid(fprice, i, InStr(fprice, "</") - i) 

那么这里主要分的清理后的版本。正如评论中所述，它将Convert.ToSingle(s)更改为CSng(s)，因为前者不会在VBA中编译。

请注意，我定义了一个工作表以用于所有操作。您在某些行中指定了Sheet2，但在其他行中留下了Cells和Ranges不合格。这也消除了对ActiveCell的引用，而是使用For循环索引，这是一个更好的做法。

我注释掉了你的'.Range("B4").Value = cid这一行 - 不确定你在那里想要什么，但是如果你真的使用它，你会想把它和所有其他行相关。我还删除了两个未使用的变量 - 看起来像你有很多，只是用于那些正在使用的:)。

我也修复了你的LastRow计算。

最后，我将CreateObject移到循环的外面。我觉得它工作正常那样：

Sub Shares() 
Dim ws As Excel.Worksheet 
Dim objMsxm12 As Object 
Dim EPIC As String 
Dim fprice As String 
Dim sPrice As Single 
Dim pPrice As Single 
Dim Shares As Integer 
Dim Cost As Single 
Dim MktVl As Single 
Dim L As Single 
Dim url As String 
Dim StartNumber As Integer 
Dim EndNumber As Integer 
Dim x As String 
Dim cid As Integer 
Dim fcid As String 

Set ws = ActiveSheet 
Set objMsxm12 = CreateObject("msxml2.xmlhttp") 
With ws 
    EndNumber = .Range("A" & .Rows.Count).End(xlUp).Row 
    For StartNumber = 2 To EndNumber 
     With .Cells(StartNumber, 1) 
      EPIC = .Value 
      url = "http://www.google.com/finance?q=" & EPIC 
      With objMsxm12 
       .Open "GET", url, False 
       .send 
       x = .ResponseText 
      End With 
      fcid = (Mid(x, InStr(1, x, "cid="), 15)) 
      cid = ExtractCID(fcid) 
      '.Range("B4").Value = cid 
      fprice = Mid(x, InStr(1, x, cid & "_l") + Len(cid) + 3, 15) 
      sPrice = TakePrice(fprice) 
      .Offset(0, 1).Value = sPrice 
      pPrice = .Offset(0, 2).Value 
      Shares = .Offset(0, 3).Value 
      Cost = pPrice * Shares 
      .Offset(0, 4).Value = Cost 
      .Offset(0, 5).Value = ((sPrice - pPrice)/pPrice) * 100 
      MktVl = sPrice * Shares 
      .Offset(0, 6).Value = MktVl 
      .Offset(0, 7).Value = MktVl - Cost 
      L = ((MktVl - Cost)/Cost) * 100 
      .Offset(0, 8).Value = L 
      If L < 0 Then 
       .Offset(0, 8).Interior.Color = RGB(255, 0, 0) 
      Else 
       .Offset(0, 8).Interior.ColorIndex = xlNone 
      End If 
     End With 
    Next StartNumber 
End With 
Set objMsxm12 = Nothing 
End Sub 

最后，我想改变这一切的Single声明来Double和Integers到Longs。这些是本地类型，他们会表现得一样好或更好。