网抓：VBA获取通达信龙虎榜单页面文字内容到EXCEL

获取文本内容，结合正则表达式，分析数据到表格。



Option Explicit

Private Sub CommandButton1_Click()

    Dim N As Long
    Dim str As String
    Dim mStr As String

    Dim regEx As Object
    Dim Match As Object
    Dim Matchs As Object

    str = GetstrSource1('001319')   '获取文本
   
    Set regEx = CreateObject('vbscript.regexp')

    regEx.Global = True  '全局有效
    regEx.MultiLine = True   '多行有效
    regEx.IgnoreCase = True  '忽略大小写

    regEx.Pattern = '\[\[[\s\S]*?\]]'
    str = regEx.Execute(str).Item(0)
    regEx.Pattern = '\[[\s\S]*?\]'
    Set Match = regEx.Execute(str)

    Dim zDate As String
    For N = 1 To Match.Count
        mStr = Match.Item(N - 1)   '内容
        mStr = Replace(mStr, 'null', Chr(34) & Chr(34))
        mStr = Replace(Replace(mStr, 'B', '买入'), 'S', '卖出')
        mStr = Replace(Replace(mStr, 'dr', '当日'), '3r', '3日')
        regEx.Pattern = '''[\s\S]*?'''
        Set Matchs = regEx.Execute(mStr)
        Cells(N + 3, 1) = NewStock(Replace(Matchs.Item(1), Chr(34), ''))
        Cells(N + 3, 2) = Replace(Matchs.Item(0), Chr(34), '')
        Cells(N + 3, 3) = Replace(Matchs.Item(2), Chr(34), '')
        Cells(N + 3, 4) = Replace(Matchs.Item(3), Chr(34), '')
        Cells(N + 3, 5) = Replace(Matchs.Item(4), Chr(34), '')
        Cells(N + 3, 6) = Replace(Matchs.Item(5), Chr(34), '')
        Cells(N + 3, 7) = Replace(Matchs.Item(6), Chr(34), '')
        Cells(N + 3, 8) = Replace(Matchs.Item(7), Chr(34), '')
        Cells(N + 3, 9) = Replace(Matchs.Item(8), Chr(34), '')
        zDate = Replace(Matchs.Item(9), Chr(34), '')
        Cells(N + 3, 10) = Format(CDate(zDate), ' yyyy-mm-dd')
    Next N
End Sub

Private Function GetstrSource1(sCode As String) As String
    Dim Url As String
    Url = 'http://page.:7615/TQLEX?Entry=CWServ.cfg_fx_yzlhb'
    Dim strSend As String
    strSend = '{''Params'':['
    strSend = strSend & '''yybxq'','
    strSend = strSend & ''''',' & ''''','
    strSend = strSend & '''' & sCode & ''','
    strSend = strSend & ''''',' & '0,20]}'
    '{'Params':['yybxq','','','001319','',0,20]}
    With CreateObject('MSXML2.XMLHTTP')
        .Open 'POST', Url, False
        .send CStr(strSend)
        GetstrSource1 = StrConv(.responseText, vbNarrow)
    End With
End Function

Private Function NewStock(strStock As String) As String
    Select Case Left(strStock, 2)
        Case '60', '68', '11'
            NewStock = 'sh' & Replace(strStock, Chr(34), '')
        Case '00', '30', '12'
            NewStock = 'sz' & Replace(strStock, Chr(34), '')
        Case Else
            NewStock = 'bj' & Replace(strStock, Chr(34), '')
    End Select
End Function