实时共享价格更新
我一直在把这个小程序放在一起，根据用户input的公司代码从Google财经中提取实时股价。 然而，我定义的第一个函数（在顶部）只适用于AAPL，而不适用于其他任何公司代码，第二个函数（find价格）在第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 在TakePrice函数中更改该行：
s = Mid(fprice, i, InStr(fprice, "</") - 1)
至
s = Mid(fprice, i, InStr(fprice, "</") - i)
那么这里是主要Sub的清理版本。 如注释中所述，它将Convert.ToSingle(s)更改为CSng(s) ，因为前者不会在VBA中编译。
请注意，我定义了一个工作表用于所有操作。 您已经在某些行中指定了Sheet2 ，但是其他Cells和Ranges不合格。 这也消除了对ActiveCell引用，而是使用For循环索引，这是一个更好的做法。
我注释了你的'.Range("B4").Value = cid line – 不确定你想要在那里，但是如果你真的使用它， 我还删除了两个未使用的variables – 看起来你已经有了很多，只是在使用这些variables:)。
我也修复了你的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 。 这些是本地types，他们会performance得更好或更好。