EXCEL自动抓取每天股票信息源码 Excel爬虫股票信息源码 在线股票操盘手源码 VBA实时自动抓取每天股票信息源码 VBA实时爬虫股票信息源码

最新Excel自动获取股票信息源码 EXCEL自动获取网络数据 最新VBA自动抓取股票数据源码

只要输入股票代码就可以获取股票最新交易信息

源代码下载

通过接口获取股票数据内容的主要优点包括以下几点：

实时性高：通过访问股票数据接口，可以实时获取到股票的实时行情数据，包括当前股价、涨跌幅、成交量、市盈率等信息，保证了股票数据的实时性。

数据准确性高：由于股票数据接口的数据来源通常是官方数据源或金融机构，因此股票数据的准确性和可信度相对较高，可以满足各种应用场景的需求。

方便快捷：通过股票数据接口获取数据非常方便快捷，只需要访问相应的API接口，并解析返回的数据即可，无需进行复杂的数据采集和处理。

兼容性强：股票数据接口通常支持多种数据格式，包括XML、JSON等，可以满足不同开发语言和应用场景的需求，具有很好的兼容性。

通过接口获取股票数据内容具有实时性高、数据准确性高、方便快捷、兼容性强等优点，因此被广泛应用于股票交易、投资分析、金融决策等领域。

Excel可以通过接口获取股票数据。Excel提供了多种方式获取数据，包括数据连接、VBA编程等，可以方便地从股票数据接口中获取实时的股票行情

'切换状态
Sub stopOpenAuto()
    RunShift = Not RunShift
    sMacro = "getNewGS"
    If RunShift Then
        Sheet1.Range("D1").Value = "实时更新"
        Call getNewGS
    Else
        Application.OnTime EarliestTime:=fireTime, Procedure:=sMacro, Schedule:=False
        Sheet1.Range("D1").Value = "关闭更新"
    End If

End Sub


'如果还在运行就关闭
Public Sub stopAuto()
    If RunShift = True Then
        RunShift = Not RunShift
        sMacro = "getNewGS"
        Application.OnTime EarliestTime:=fireTime, Procedure:=sMacro, Schedule:=False
         Sheet1.Range("D1").Value = "关闭更新"
    End If
End Sub

Sub getNewGS()
    Dim url As String
    Dim result As String
    Dim arrResult As Variant
    Dim temp As String
    Dim title As String
    Dim arrTitle As Variant
    Dim max As Integer
    Dim ii As Integer
    Dim mm As Integer
    Dim lngRow As Long
    Dim key As String
    Dim kk As Long
            
    title = "名称,代码,当前价格,昨收,今开,成交量（手）,外盘,内盘,买一,买一量（手）"
    title = title & ",买二,买二量（手）,买三,买三量（手）,买四,买四量（手）,买五,买五量（手）,卖一,卖一量,卖二,卖二量,卖三"
    title = title & ",卖三量,卖四,卖四量,卖五,卖五量,最近逐笔成交,时间,涨跌,涨跌%,最高,最低,价格/成交量（手）/成交额,成交量（手）"
    title = title & ",成交额（万）,换手率,市盈率,无信息,最高,最低,振幅,流通市值,总市值,市净率,涨停价,跌停价"
    
    arrTitle = Split(title, ",")
    max = UBound(arrTitle)
    
    If RunShift Then
        '获取固定的上证指数
        url = "https://xx.xx.xxx/WX=w1766168900"
        With CreateObject("MSXML2.XMLHTTP")
             .Open "GET", url, False
             .Send
             result = .responseText
         End With
         If VBA.Len(result) > 30 Then
            arrResult = Split(result, "~")
            ThisWorkbook.Sheets(1).Range("AL1").Value = "上证指数"
            ThisWorkbook.Sheets(1).Range("AM1").Value = arrResult(3)
            ThisWorkbook.Sheets(1).Range("AO1").Value = "上次收盘"
            ThisWorkbook.Sheets(1).Range("AP1").Value = arrResult(4)
            ThisWorkbook.Sheets(1).Range("AM1").Interior.ColorIndex = IIf(CDbl(ThisWorkbook.Sheets(1).Range("AM1").Value) > CDbl(ThisWorkbook.Sheets(1).Range("AP1").Value), 46, 43) '上证指数
         End If
         
         '获取固定的深证指数
        url = "https://xx.xx.xxx/WX=w1766168900"
        With CreateObject("MSXML2.XMLHTTP")
             .Open "GET", url, False
             .Send
             result = .responseText
         End With
         If VBA.Len(result) > 30 Then
            arrResult = Split(result, "~")
            ThisWorkbook.Sheets(1).Range("AR1").Value = "深证指数"
            ThisWorkbook.Sheets(1).Range("AS1").Value = arrResult(3)
            ThisWorkbook.Sheets(1).Range("AT1").Value = "上次收盘"
            ThisWorkbook.Sheets(1).Range("AU1").Value = arrResult(4)
            ThisWorkbook.Sheets(1).Range("AS1").Interior.ColorIndex = IIf(CDbl(ThisWorkbook.Sheets(1).Range("AS1").Value) > CDbl(ThisWorkbook.Sheets(1).Range("AU1").Value), 46, 43) '深证指数数
         End If
        
        
        '找到当前表的数据最后一行的行号
        lngRow = Cells(Rows.Count, 2).End(xlUp).Row
        
        For kk = 3 To lngRow
            
            '获取股票代码
            key = "sz" + Sheet1.Range("B" & kk).Value
            url = "http://xxx.xxx.xx//WX=w1766168900&q=" & key
            
           With CreateObject("MSXML2.XMLHTTP")
                .Open "GET", url, False
                .Send
                result = .responseText
            End With
            
            '获取数据太少则更新成另外一种方法
            If VBA.Len(result) < 30 Then
                key = "sh" + Sheet1.Range("B" & kk).Value
                url = "http://xxx.xxx.xx/WX=w1766168900&q=" & key
                 With CreateObject("MSXML2.XMLHTTP")
                    .Open "GET", url, False
                    .Send
                    result = .responseText
                End With
                If VBA.Len(result) < 30 Then
                    GoTo CONTINUE
                End If
            End If
            
            If Sheet1.Range("H2").Value = "" Then
                 For ii = 0 To UBound(arrTitle)
                   'Debug.Print arrTitle(ii)
                   ThisWorkbook.Sheets(1).Cells(2, ii + 1) = arrTitle(ii)
                 Next ii
            End If
            
            arrResult = Split(result, "~")
            
        '    For Each info In arrResult
        '        Debug.Print info
        '    Next info
             For mm = 1 To UBound(arrResult)
                If mm > (max + 1) Then
                    'Debug.Print arrResult(mm)
                    Exit For
                End If
                If mm <> 2 Then '不需要更新代码列内容
                    ThisWorkbook.Sheets(1).Cells(kk, mm) = arrResult(mm)
                End If
                
             Next mm
             
             'Debug.Print CDbl(ThisWorkbook.Sheets(1).Range("AF" & kk).Value)
             '背景色
             ThisWorkbook.Sheets(1).Range("C" & kk).Interior.ColorIndex = IIf(CDbl(ThisWorkbook.Sheets(1).Range("AF" & kk).Value) > 0, 46, 43) '当前价格
             ThisWorkbook.Sheets(1).Range("AF" & kk).Interior.ColorIndex = IIf(CDbl(ThisWorkbook.Sheets(1).Range("AF" & kk).Value) > 0, 46, 43) '涨跌%
             
CONTINUE:
         Next kk
         
         'Application.OnTime Now + TimeValue("00:00:02"), sMacro
         fireTime = Now + TimeValue("00:00:02")
         Application.OnTime EarliestTime:=fireTime, Procedure:=sMacro, Schedule:=True
     End If
    
End Sub