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)

然后这是一个主要Sub的清理版本。正如评论中所提到的，它将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。这些是原生类型，它们实际上表现得更好或更好。

实时共享价格更新

1 个答案: