VBAnetworking数据不显示整个表
我试图将表格下载到一个Excel工作表，然后循环到下一个表。循环工作（虽然很慢），但我只是得到了页面的顶部（前5行狗名称教练名称等）和主表不出现。我也得到了Cookie消息。 任何build议最受欢迎：
Option Explicit Sub Macro1() Sheets("Sheet1").Select Range("A1").Select Dim i As Integer Dim e As integer Dim myurl As String, shorturl As String Sheets("Sheet1").Select i = 1 Do While i < 3 myurl = "URL;http://www.racingpost.com/greyhounds/dog_home.sd?dog_id=" & i & "" With ActiveSheet.QueryTables.Add(Connection:=myurl, Destination:=Range("$A$1")) .Name = shorturl .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlEntirePage .WebFormatting = xlWebFormattingNone .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False .Refresh BackgroundQuery:=False .WebDisableDateRecognition = False .WebDisableRedirections = False .Refresh BackgroundQuery:=False End With Columns("A:J").Select Selection.Copy Range("K1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Columns("A:J").Select Range("J1").Activate Application.CutCopyMode = False Selection.Delete Shift:=xlToLeft Columns("A:J").Select Selection.ColumnWidth = 20.01 Columns("B:B").Select Selection.ColumnWidth = 20.01 Rows("1:9").Select Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove i = i + 1 Loop End Sub 表格数据在初始页面加载之后通过ajax请求加载。
如果你用chrome查看页面并打开developer tools (F12) -> Network Tab 。 您将看到以下url的额外请求： http://www.racingpost.com/greyhounds/dog_form.sd?dog_id= ： http://www.racingpost.com/greyhounds/dog_form.sd?dog_id= dog_id http://www.racingpost.com/greyhounds/dog_form.sd?dog_id=
您用来检索数据的方法很慢。 加快速度的一种方法是通过xmlhttprequest请求url，并parsing你自己需要的相应数据。
下面是一个xmlhttprequest的例子（注意，返回的数据是一个可以parsing的源代码的string）：
Function XmlHttpRequest(url As String) As String Dim xml As Object Set xml = CreateObject("MSXML2.XMLHTTP") xml.Open "GET", url, False xml.send XmlHttpRequest = xml.responseText End Function
所以通过这个方法请求数据看起来像这样：
response = XmlHttpRequest("http://www.somesite.com")
这可能是我知道从网站上检索数据的最快速的方法，因为它不涉及实际的渲染。
然后parsing任何给定的数据，您需要在数据源前面或后面查找相同的数据。 （通常具有特定的类名称或类似的东西）。 一个通用的parsing可能是这样的：
loc1 = instr(response,"MyClassName") loc1 = instr(loc1, response, ">") + 1 'the exact beginning of the data i'd like loc2 = instr(loc1, response, "</td>")' the end of the data i'd like data = trim(mid(response,loc1,loc2-loc1))
最后，这里是所有你可以粘贴的方法来启动和运行。 我不知道你是什么字段后，所以我只是从每个页面parsing了几个例子：
Option Explicit Sub GetTrackData() Dim response As String Dim dogHomeUrl As String Dim dogFormUrl As String Dim i As Integer Dim x As Integer Dim dogName As String Dim dogDate As String Dim trainer As String Dim breeding As String Dim loc1 As Long, loc2 As Long dogHomeUrl = "http://www.racingpost.com/greyhounds/dog_home.sd?dog_id=" dogFormUrl = "http://www.racingpost.com/greyhounds/dog_form.sd?dog_id=" x = 2 For i = 1 To 10 response = XmlHttpRequest(dogHomeUrl & i) Debug.Print (response) 'parse the overall info 'this is the basic of parsing the web page 'just find the start of the data you want with instr 'then find the end of the data with instr 'and use mid to pull out the data we want 'rinse and repeat this method for every line of data we'd like loc1 = InStr(response, "popUpHead") loc1 = InStr(loc1, response, "<h1>") + 4 loc2 = InStr(loc1, response, "</h1>") dogName = Trim(Mid(response, loc1, loc2 - loc1)) 'apparantly if dog name is blank there is data to report on the web site If dogName <> "" Then 'now lets get the dogDate loc1 = InStr(loc2, response, "<li>") loc1 = InStr(loc1, response, "(") + 1 loc2 = InStr(loc1, response, ")") dogDate = Trim(Mid(response, loc1, loc2 - loc1)) 'now the trainer loc1 = InStr(loc2, response, "<strong>Trainer</strong>") + 24 loc2 = InStr(loc1, response, "</li>") trainer = Trim(Mid(response, loc1, loc2 - loc1)) response = XmlHttpRequest(dogFormUrl & i) 'now we need to loop through the form table and parse out the values we care about loc1 = InStr(response, "Full Results") Do While (loc1 <> 0) Dim raceDate As String Dim raceTrack As String Dim dis As String loc1 = InStr(loc1, response, ">") + 1 loc2 = InStr(loc1, response, "</a>") raceDate = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<td>") + 4 loc2 = InStr(loc1, response, "</td>") raceTrack = Trim(Mid(response, loc1, loc2 - loc1)) Range("A" & x).Value = dogName Range("B" & x).Value = dogDate Range("C" & x).Value = trainer Range("D" & x).Value = raceDate Range("E" & x).Value = raceTrack loc1 = InStr(loc2, response, "Full Results") x = x + 1 Loop Debug.Print (response) End If 'parse the form table Next i End Sub Function XmlHttpRequest(url As String) As String Dim xml As Object Set xml = CreateObject("MSXML2.XMLHTTP") xml.Open "GET", url, False xml.send XmlHttpRequest = xml.responseText End Function
编辑1
我们进行交stream的数据是错误的，第一栏并不总是链接。 这是一个修改的例子，更多的字段被parsing。 如果您有任何问题，请告知我们：
Option Explicit Sub GetTrackData() Dim response As String Dim dogHomeUrl As String Dim dogFormUrl As String Dim i As Integer Dim x As Integer Dim dogName As String Dim dogDate As String Dim trainer As String Dim breeding As String Dim loc1 As Long, loc2 As Long Dim qt As String qt = """" dogHomeUrl = "http://www.racingpost.com/greyhounds/dog_home.sd?dog_id=" dogFormUrl = "http://www.racingpost.com/greyhounds/dog_form.sd?dog_id=" x = 2 For i = 1 To 10 response = XmlHttpRequest(dogHomeUrl & i) Debug.Print (response) 'parse the overall info 'this is the basic of parsing the web page 'just find the start of the data you want with instr 'then find the end of the data with instr 'and use mid to pull out the data we want 'rinse and repeat this method for every line of data we'd like loc1 = InStr(response, "popUpHead") loc1 = InStr(loc1, response, "<h1>") + 4 loc2 = InStr(loc1, response, "</h1>") dogName = Trim(Mid(response, loc1, loc2 - loc1)) 'apparantly if dog name is blank there is data to report on the web site If dogName <> "" Then 'now lets get the dogDate loc1 = InStr(loc2, response, "<li>") loc1 = InStr(loc1, response, "(") + 1 loc2 = InStr(loc1, response, ")") dogDate = Trim(Mid(response, loc1, loc2 - loc1)) 'now the trainer loc1 = InStr(loc2, response, "<strong>Trainer</strong>") + 24 loc2 = InStr(loc1, response, "</li>") trainer = Trim(Mid(response, loc1, loc2 - loc1)) response = XmlHttpRequest(dogFormUrl & i) 'now we need to loop through the form table and parse out the values we care about loc1 = InStr(response, "<td class=" & qt & "first" & qt) + 17 Do While (loc1 > 17) Dim raceDate As String Dim raceTrack As String Dim dis As String Dim trp As String Dim splt As String Dim pos As String Dim fin As String Dim by As String Dim winSec As String Dim remarks As String Dim time As String Dim going As String Dim price As String Dim grd As String Dim calc As String loc1 = InStr(loc1, response, ">") + 1 loc2 = InStr(loc1, response, "</td>") raceDate = Trim(Mid(response, loc1, loc2 - loc1)) If InStr(raceDate, "<a href") > 0 Then 'we have a link so parse out the date from the link Dim tem1 As Long Dim tem2 As Long tem1 = InStr(raceDate, ">") + 1 tem2 = InStr(tem1, raceDate, "</a>") raceDate = Trim(Mid(raceDate, tem1, tem2 - tem1)) End If loc1 = InStr(loc2, response, "<td>") + 4 loc2 = InStr(loc1, response, "</td>") raceTrack = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<td><span class=") + 16 loc1 = InStr(loc1, response, ">") + 1 loc2 = InStr(loc1, response, "</span>") dis = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<td class=") loc1 = InStr(loc1, response, ">") + 1 loc2 = InStr(loc1, response, "</td>") trp = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<td>") + 4 loc2 = InStr(loc1, response, "</td>") splt = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<td>") + 4 loc2 = InStr(loc1, response, "</td>") pos = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<span class= " & qt & "black" & qt & ">") + 21 loc2 = InStr(loc1, response, "</span>") fin = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<td>") + 4 loc2 = InStr(loc1, response, "</td>") by = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<a href=") + 8 loc1 = InStr(loc1, response, ">") + 1 loc2 = InStr(loc1, response, "</a>") winSec = Trim(Mid(response, loc1, loc2 - loc1)) '<td><i> loc1 = InStr(loc2, response, "<td><i>") + 7 loc2 = InStr(loc1, response, "</i>") remarks = Trim(Mid(response, loc1, loc2 - loc1)) '<span class="black"> loc1 = InStr(loc2, response, "<span class=" & qt & "black" & qt & ">") + 21 loc2 = InStr(loc1, response, "</span>") time = Trim(Mid(response, loc1, loc2 - loc1)) '<td class="center"> loc1 = InStr(loc2, response, "<td class=" & qt & "center" & qt & ">") + 19 loc2 = InStr(loc1, response, "</td>") going = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<td class=" & qt & "center" & qt & ">") + 19 loc2 = InStr(loc1, response, "</td>") price = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<td class=" & qt & "center" & qt & ">") + 19 loc2 = InStr(loc1, response, "</td>") grd = Trim(Mid(response, loc1, loc2 - loc1)) Range("A" & x).Value = dogName Range("B" & x).Value = dogDate Range("C" & x).Value = trainer Range("D" & x).Value = raceDate Range("E" & x).Value = raceTrack Range("F" & x).Value = dis Range("G" & x).Value = trp Range("H" & x).Value = splt Range("I" & x).Value = pos Range("J" & x).Value = fin Range("K" & x).Value = by Range("L" & x).Value = winSec Range("M" & x).Value = remarks Range("N" & x).Value = time Range("O" & x).Value = going Range("P" & x).Value = price Range("Q" & x).Value = grd loc1 = InStr(loc2, response, "<td class=" & qt & "first" & qt) + 17 x = x + 1 Loop Debug.Print (response) End If 'parse the form table Next i End Sub Function XmlHttpRequest(url As String) As String Dim xml As Object Set xml = CreateObject("MSXML2.XMLHTTP") xml.Open "GET", url & "&cache_buster=" & GenerateRandom, False xml.send XmlHttpRequest = xml.responseText End Function Function GenerateRandom() As String GenerateRandom = Int(Rnd * 1000) End Function
感谢您的详细答复。我相对较新，我一直在处理您的代码，并遇到了一些问题，当涉及到从源parsing。我设法得到表字段的距离，位置，拆分时间和鳍罚款，但其余我不能得到。我提取了每个项目的来源，这里是一个列表与相应的行动，那些工作在右边：TOP狗的名字
安格尔西航class
date of birth an sexb <li> (3 Aug 2013) bk d </li> trainer <li><strong>Trainer</strong> JB Thompson</li> breeding <li><strong>Breeding</strong> Head Bound — Inshaarla</li> FORM DATE >18Mar15</a> </td> ' devweeks dev code works fine] TRACK <td>BVue</td> ' devweeks dev code works fine] DIS <td><span class="black">470m</span></td> [here I did +25 and - 7 and it works] TRP <td class="center">[2]</td> SPLIT [+4 works with this] <td>4.51</td> POS <td>5555</td> [+4 works with this] FIN <td><span class="black">5th</span></td> [ 25 - 7 works with this] BY <td>12</td> WIN/SEC ">Ballymac Fleetie</a> </td> REMARKS <td><i>Crd&CkdW&StruckInto1/4</i></td> TIME <td><span class="black">28.67</span></td> GOING <td class="center"> N</td> PRICE <td class="center">4/1</td> GRADE <td class="center">A5</td> CALC <td class="last right"><span>29.63</span></td> </tr>
对于余下的字段，我遇到了不同的回应。例如字段POS（位置）和SPLIT的代码是+4。但是当我将它应用于与POS和SPLIT完全相同的raceBY时，我得到以下结果。 13。 也与其他领域，我得到…（href =“http://www.racingpost.com/greyhounds/dog_home.sd?dog_id=72970”onclick =“return Html.popup（this，{width：800，height： 480}）“title =”Click for Dog Form …“> STORM FORCE …请参阅我的代码，我已经尝试了所有其他字段，并获得上述两个消息的变体。我知道我必须做的这里有什么不对，任何build议非常感谢。
Option Explicit Sub GetTrackData() Dim response As String Dim dogHomeUrl As String Dim dogFormUrl As String Dim i As Long Dim x As Long Dim dogName As String Dim dogDate As String Dim trainer As String Dim breeding As String Dim loc1 As Long, loc2 As Long dogHomeUrl = "http://www.racingpost.com/greyhounds/dog_home.sd?dog_id=" dogFormUrl = "http://www.racingpost.com/greyhounds/dog_form.sd?dog_id=" x = 2 For i = 1 To 10 response = XmlHttpRequest(dogHomeUrl & i) Debug.Print (response) 'parse the overall info 'this is the basic of parsing the web page 'just find the start of the data you want with instr 'then find the end of the data with instr 'and use mid to pull out the data we want 'rinse and repeat this method for every line of data we'd like loc1 = InStr(response, "popUpHead") loc1 = InStr(loc1, response, "<h1>") + 4 loc2 = InStr(loc1, response, "</h1>") dogName = Trim(Mid(response, loc1, loc2 - loc1)) 'apparantly if dog name is blank there is data to report on the web site If dogName <> "" Then 'now lets get the dogDate loc1 = InStr(loc2, response, "<li>") loc1 = InStr(loc1, response, "(") + 1 loc2 = InStr(loc1, response, ")") dogDate = Trim(Mid(response, loc1, loc2 - loc1)) 'now the trainer loc1 = InStr(loc2, response, "<strong>Trainer</strong>") + 24 loc2 = InStr(loc1, response, "</li>") trainer = Trim(Mid(response, loc1, loc2 - loc1)) response = XmlHttpRequest(dogFormUrl & i) 'now we need to loop through the form table and parse out the values we care about loc1 = InStr(response, "Full Results") Do While (loc1 <> 0) Dim raceDate As String Dim raceTrack As String Dim raceDis As String Dim racePos As String Dim raceSplit As String Dim raceFin As String Dim raceBy As String Dim raceTrp As String Dim raceRemarks As String Dim raceWinSec As String Dim raceTime As String Dim raceGoing As String Dim racePrice As String Dim raceGrd As String Dim raceCalc As String ' Dim raceBy As String 'Dim raceBy As String 'Dim raceWinSec As String loc1 = InStr(loc1, response, ">") + 1 loc2 = InStr(loc1, response, "</a>") raceDate = Trim(Mid(response, loc1, loc2 - loc1)) ' weeksdevcode works fine loc1 = InStr(loc2, response, "<td>") + 4 loc2 = InStr(loc1, response, "</td>") raceTrack = Trim(Mid(response, loc1, loc2 - loc1)) 'weeksdevcode works fine 'ABOVE TWO WEEKSDEV CODE '.............................................................. 'BELOW ARE MINE loc1 = InStr(loc2, response, "<td>") + 25 ' column F = DISTANCE/works loc2 = InStr(loc1, response, "</td>") - 7 raceDis = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<td>") + 4 'column G = POSITION/works loc2 = InStr(loc1, response, "</td>") racePos = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<td>") + 4 'column H = SPLIT/works loc2 = InStr(loc1, response, "</td>") raceSplit = Trim(Mid(response, loc1, loc2 - loc1)) loc1 = InStr(loc2, response, "<td>") + 25 'column I =FINISH/works loc2 = InStr(loc1, response, "</td>") - 7 raceFin = Trim(Mid(response, loc1, loc2 - loc1)) 'BELOW IS THE CODE FOR raceBy and raceRemarks 'and by the side is the results. ' loc1 = InStr(loc2, response, "<td>") + 4 '( here I get..13¾ and similar;) ' loc2 = InStr(loc1, response, "</td>") ' raceBy = Trim(Mid(response, loc1, loc2 - loc1)) ' loc1 = InStr(loc2, response, "<td>") + 7 '(Here I Geta href="http://www.racingpost.com/greyhounds/dog_home.sd?dog_id=72970" onclick="return Html.popup(this, {width:800, height:480})" title="Click for Dog Form...">STORM FORCE</a> 'loc2 = InStr(loc1, response, "</td>") ' raceRemarks = Trim(Mid(response, loc1, loc2 - loc1)) ' BELOW ARE 3 variations I tried on raceTrp 'loc1 = InStr(loc2, response, "<td>") + 18 'Here I Get.. <a href=""http://www.racingpost.com/greyhounds/dog_home.sd?dog_id=72970"" onclick=""return Html.popup(this, {width:800, height:480})"" title=""Click for Dog Form..."">STORM FORCE</a>" 'loc2 = InStr(loc1, response, "</td>") 'raceTrp = Trim(Mid(response, loc1, loc2 - loc1)) ' loc1 = InStr(loc2, response, "<td>") + 18 ' Here I Get.. <a href=""http://www.racingpost.com/greyhounds/dog_home.sd?dog_id=72970"" onclick=""return Html.popup(this, {width:800, height:480})"" title=""Click for Dog Form..."">STORM FORCE</a>" 'loc2 = InStr(loc1, response, "</td>") - 6 'raceTrp = Trim(Mid(response, loc1, loc2 - loc1)) ' loc1 = InStr(loc2, response, "class=center") 'same as above ' loc1 = InStr(loc2, response, ">") + 19 'loc2 = InStr(loc1, response, "</td>") ' raceTrp = Trim(Mid(response, loc1, loc2 - loc1)) Range("A" & x).Value = dogName Range("B" & x).Value = dogDate Range("C" & x).Value = trainer Range("D" & x).Value = raceDate Range("E" & x).Value = raceTrack ' above weeksdev all works fine Range("F" & x).Value = raceDis Range("G" & x).Value = racePos Range("H" & x).Value = raceSplit Range("I" & x).Value = raceFin Range("J" & x).Value = raceBy Range("K" & x).Value = raceTrp Range("L" & x).Value = raceRemarks Range("M" & x).Value = raceWinSec Range("N" & x).Value = raceTime Range("O" & x).Value = raceGoing Range("M" & x).Value = racePrice Range("N" & x).Value = raceGrd Range("O" & x).Value = raceCalc loc1 = InStr(loc2, response, "Full Results") x = x + 1 Loop Debug.Print (response) End If 'parse the form table Next i End Sub Function XmlHttpRequest(url As String) As String Dim xml As Object Set xml = CreateObject("MSXML2.XMLHTTP") xml.Open "GET", url, False xml.send XmlHttpRequest = xml.responseText End Function
亲切的问候Col