怎么修改抓取股票成交明细的vba程序

guodong321654

提取网址
网址利民股份(002734)成交明细_财经_凤凰网  http://app.finance.ifeng.com/dat ... 3.php?code=sz002734

Exsel 2003版


Sub CJMX()

    Dim VBt, YB
    Dim Wb
    Set VBt = GetObject(, "Excel.Application")
    Set YB = VBt.ActiveSheet
    Set Wb = VBt.ThisWorkbook
    Dim sp
    Dim DD
    Dim Arr(15000, 5), Num&
    Dim url, ul, html, tb, i&, j&, k&, dm, iRow
    dm = Wb.Sheets("个研").[i1].Value
    If Len(CStr(dm)) <> 6 Or IsNumeric(dm) = False Then Exit Sub
    If Left(dm, 1) = "6" Then dm = "sh" & dm Else dm = "sz" & dm
    url = "http://app.finance.ifeng.com/data/stock/stock_item3.php?"
    url = url & "code=" & dm
    url = url & "&page="
    Wb.Sheets("个研").[a2:e9999] = "": Wb.Sheets("个研").[L1] = "获取中..."
   Set html = CreateObject("htmlfile")
    iRow = 2: Num = 1
    With CreateObject("msxml2.xmlhttp")
        For k = 1 To 100
            ul = url & k
            .Open "get", ul, False
            .send
            html.body.innerhtml = StrConv(.ResponseBody, vbUnicode)
            Set tb = html.All.tags("table")(3).Rows
            For i = 1 To tb.Length - 1
                For j = 0 To tb(i).Cells.Length - 1
                    If IsNumeric(Left(tb(i).Cells(0).innertext, 1)) = False Then Wb.Sheets("个研").[L1] = "": Wb.Sheets("个研").Cells(iRow, 1).Resize(Num, 7) = Arr: Exit Sub
                    Arr(Num, j + 1) = tb(i).Cells(j).innertext
                Next
                Num = Num + 1
            Next
        Next
    End With
   Wb.Sheets("个研").[L1] = ""
End Sub

hlxue

Option Base 1
Sub CJMX()

    Dim VBt, YB
    Dim Wb
    Set VBt = GetObject(, "Excel.Application")
    Set YB = VBt.ActiveSheet
    Set Wb = VBt.ThisWorkbook
    Dim sp
    Dim DD
    Dim Arr(15000, 5), Num&
    Dim url, ul, html, tb, i&, j&, k&, dm, iRow
    dm = Wb.Sheets("个研").[i1].Value
    If Len(CStr(dm)) <> 6 Or IsNumeric(dm) = False Then Exit Sub
    If Left(dm, 1) = "6" Then dm = "sh" & dm Else dm = "sz" & dm
    url = "http://app.finance.ifeng.com/data/stock/stock_item3.php?"
    url = url & "code=" & dm
    url = url & "&page="
    Wb.Sheets("个研").[a2:e9999] = "": Wb.Sheets("个研").[L1] = "获取中..."
   Set html = CreateObject("htmlfile")
    iRow = 2: Num = 1
    With CreateObject("msxml2.xmlhttp")
        For k = 1 To 100
            ul = url & k
            .Open "get", ul, False
            .send
            html.body.innerhtml = .Responsetext
            Set tb = html.All.tags("table")(0).Rows
            For i = 1 To tb.Length - 1
                For j = 0 To tb(i).Cells.Length - 1

                    Arr(Num, j + 1) = tb(i).Cells(j).innertext
                Next
                Num = Num + 1
            Next
        Next
    End With
    Wb.Sheets("个研").Range("A2:E" & UBound(Arr)) = Arr
   Wb.Sheets("个研").[L1] = ""
End Sub

perfect131

可以 直接复制粘贴
https://club.excelhome.net/thread-1628424-1-1.html

这个表格 已经在静态源码里，所以 只要定位到表格 复制粘贴就完事
定位


复制粘贴 仅供参考

lhj323323

hlxue 发表于 2024-1-3 14:05
Option Base 1
Sub CJMX()

老师：
能否把2楼的源码，与单元格【J1】日期进行关联？

hlxue

lhj323323 发表于 2024-1-14 11:48
老师：
能否把2楼的源码，与单元格【J1】日期进行关联？

网页只有当前成交明细，没有历史数据，改变日期没有用！

lhj323323

hlxue 发表于 2024-1-15 09:59
网页只有当前成交明细，没有历史数据，改变日期没有用！

明白了，谢谢老师回复。