已解决：VBA将东方财富网龙虎榜个股明细放入excel表格中

俊锋伍贰零

http://data.eastmoney.com/soft/s ... 323&date=2017-03-31
求教：：：如何用VBA将这个页面（东方财富网龙虎榜个股明细）放入excel表格中……因为这个网页不够精简……O(∩_∩)O谢谢

phsu

Sub test()
    Dim QT As QueryTable
    With ActiveSheet
        Set QT = .QueryTables.Add("URL;http://data.eastmoney.com/soft/s ... amp;date=2017-03-31", .Range("A1"))
    End With
    QT.Refresh False
End Sub

phsu

請參閲附件。

俊锋伍贰零

phsu 发表于 2017-4-2 17:15
請參閲附件。

非常感谢，网页是转入到表格内了，但能否精简一下，就是只有个股明细，其他的都不要
如图保留最上面的蓝色区域

mzbao

1. Sub GetStockDetail()
   
2.     Dim Adr$, sCode$, sDate$, r%
   
3.    
   
4.     Adr = "http://data.eastmoney.com/soft/stock/StockDetail.aspx?"
   
5.     sCode = [B3].Value
   
6.     sDate = Format([B4].Value, "yyyy-mm-dd")
   
7.     Adr = Adr & "code=" & sCode
   
8.     Adr = Adr & "&date=" & sDate
   
9.    
   
10.     With Range("A7").Resize(100, 20)
    
11.         .ClearContents
    
12.         .Borders.LineStyle = xlNone
    
13.     End With
    
14.     Set HTML = CreateObject("htmlfile")
    
15.     With CreateObject("msxml2.xmlhttp")
    
16.         .Open "get", Adr, False
    
17.         .send
    
18.         HTML.body.innerhtml = .responsetext
    
19.         
    
20.         r = 7
    
21.         Set tb = HTML.all.tags("table")(0).Rows
    
22.         For i = 0 To tb.Length - 1
    
23.             For j = 0 To tb(i).Cells.Length - 1
    
24.                 Cells(i + r, j + 1) = tb(i).Cells(j).innertext
    
25.             Next
    
26.         Next
    
27.         Range(Cells(8, 1), Cells(i + r - 1, j)).Borders.LineStyle = xlContinuous
    
28.         
    
29.         r = i + 7 + 1
    
30.         Set tb = HTML.all.tags("table")(1).Rows
    
31.         For i = 0 To tb.Length - 1
    
32.             For j = 0 To tb(i).Cells.Length - 1
    
33.                 Cells(i + r, j + 1) = tb(i).Cells(j).innertext
    
34.             Next
    
35.         Next
    
36.         
    
37.         '下面调整格式而已
    
38.         r = r - 1
    
39.         Range(Cells(i + r, 3), Cells(i + r, j + 1)) = Range(Cells(i + r, 2), Cells(i + r, j)).Value
    
40.         Cells(i + r, 2) = ""
    
41.         Range(Cells(r + 2, 1), Cells(i + r, j + 1)).Borders.LineStyle = xlContinuous
    
42.         
    
43.         Union(Cells(i + r, 3), Cells(i + r, 5)).NumberFormatLocal = "G/通用格式"
    
44.     End With
    
45. End Sub
    

复制代码

phsu

Sub test()
    Dim QT As QueryTable
    With ActiveSheet
        Set QT = .QueryTables.Add("URL;http://data.eastmoney.com/soft/s ... amp;date=2017-03-31", .Range("A1"))
    End With
    With QT
        .WebTables = "1,2"
        .Refresh False
    End With
End Sub

phsu

請參閲附件。

俊锋伍贰零

phsu
mzbao
非常非常感谢两位老师！！！你们太强大 了！！！

俊锋伍贰零

phsu
mzbao  



老师好，请教您一下：
如何将表头也弄到excel中呢？我找不到这些文字……
表头内容：
2017-03-31 星期五

• 类型：当日涨幅偏离值达7%的证券
• 收盘价：18.32元     涨跌幅：10.03%     成交量：3244.51万股     成交金额：58853.41万元
  

俊锋伍贰零

@phsu
@mzbao

老师好，请教您一下：
如何将表头也弄到excel中呢？我找不到这些文字……