VBA实例–excel抓取页面上的数据【转】

来源 http://club.excelhome.net/

Sub a()
Dim ie1 As Object, dmt As Object, r As Object, i As Long, j As Long, k As Long
[a1].CurrentRegion.Clear
Cells.NumberFormat = "@"
Set ie1 = CreateObject("InternetExplorer.Application")
With ie1
  '.Visible = True
  .Navigate "http://quotes.money.163.com/stock/#query=EQA" '网址
  Do Until .ReadyState = 4
   ' DoEvents
  Loop
  Set dmt = .Document
End With

Set r = dmt.All.tags("table")(1).Rows
  For i = 1 To r.Length - 2
   For j = 0 To r(i).Cells.Length - 1
     Cells(i, j + 1) = r(i).Cells(j).innerText
      
Next
Next
Set r = dmt.All.tags("table")(2).Rows
j = 11
  For i = 1 To r.Length - 2
   'For j = 0 To r(i).Cells.Length - 1
     Cells(i, 4) = r(i).Cells(j).innerText
      
' Next
Next

'ie1.Quit
Set ie1 = Nothing
Set dmt = Nothing
Set r = Nothing

[a1].CurrentRegion.Columns.AutoFit


End Sub

第二个实例:

Sub CommandButton1_Click()
    Columns("A:F").NumberFormatLocal = "@"
    On Error Resume Next
    With CreateObject("Microsoft.XMLHTTP")
        With CreateObject("msscriptcontrol.scriptcontrol")
            .Language = "JavaScript"
            hm = .Eval("(new Date).getTime();")
        End With
        .Open "GET", "https://www.acttab.com.au/interbet/kenoreswin;" & hm, False    '下载100行数据,改一改“nlist=100”中的100,就可以下载任意行
        .send
        ss = Split(Split(Split(.responsetext, "value=""")(1), ":"">")(0), ":")
        For p = 0 To UBound(ss)
            ss1 = Split(Split(ss(p), ";")(0), ",")
            Cells(p + 1, 1) = "Draw #" & ss1(0) & " at " & ss1(1) & ":" & ss1(2) & ":" & ss1(3)
            a = Split(Split(ss(p), ";")(1), ",")
            For q = 1 To 2
                M = 0
                For i = 0 To 19
                    If Val(a(i)) <= Val(a(i + 1)) Then
                        If i > M Then
                            M = i
                        Else
                            i = M
                        End If
                        GoTo k1:
                    Else
                        x = a(i)
                        a(i) = a(i + 1)
                        a(i + 1) = x
                        If i <> 1 Then i = i - 2
                    End If
k1:
                Next i
            Next q
            Range(Cells(p + 1, 2), Cells(p + 1, "U")) = a
        Next p
    End With
End Sub


本文地址: http://www.bagualu.net/wordpress/archives/5307 转载请注明




发表评论

电子邮件地址不会被公开。 必填项已用*标注