用VBA按网页下拉框指定期号抓取所需内容

WYS67

mzbao 发表于 2018-12-2 14:29

老师编写的代码很好！以最新附件只需修改下面几处，就能圆满实现我的心中所想：
1.A5:C85932开奖历史数据的排列顺序：
     要么以http://kaijiang.500.com/jsk3.shtml 下拉框里的顺序【全倒序】：2018-11-30--2018-11-29--2018-11-28......直到B2指定的2015-11-03结束，这样，下一步只需把A5:C85932里抓取到的数据上下倒置，就是日期期号的升序排列；
      要么把B2指定151103001【开始期号】【全正序】填入A5,以下是151103002......151103082；1511104001-1511104082；直至181130001-181130082结束，这样，抓取到的数据不需要进行上下倒置，直接就是日期期号的升序排列，方便了下一步的统计。



2.指定B1为需要抓取数据的网址，B2为抓取数据的开始期号，B3为抓取数据的结束期号，把B1:B3当作变量写入代码。这样同一个sub过程，在工作表《江苏快三》里抓取的是“江苏快三”的历史数据，而在工作表《安徽快三》里，抓取的则是“安徽快三”的历史数据。
麻烦老师按照上面两点修改和完善代码。最新附件如下：

按B1指定的网址和B2B3指定的期号下载开奖数据.zip (1.67 MB, 下载次数: 8)

2018-12-2 16:20 上传

点击文件名下载附件

WYS67

mzbao 发表于 2018-12-2 14:29

恳请老师按21楼要求修改和完善代码

WYS67

恳请老师按21楼要求修改和完善18楼的代码

Kaohsing

建议你，分段抓取数据，慢慢积累数据，以防ip被封，至于倒着排列，录个排序的宏就完事了。

WYS67

Kaohsing 发表于 2018-12-3 07:57
建议你，分段抓取数据，慢慢积累数据，以防ip被封，至于倒着排列，录个排序的宏就完事了。

感谢老师提醒。

WYS67

mzbao 发表于 2018-12-2 14:29

恳请老师按照21楼的要求，修改和完善18楼的代码。

Kaohsing

这种大概就属于io密集型。

WYS67

Kaohsing 发表于 2018-12-3 07:57
建议你，分段抓取数据，慢慢积累数据，以防ip被封，至于倒着排列，录个排序的宏就完事了。

老师：1.怎样才能把指定B1为需要抓取数据的网址写入代码？这样，只需修改B1指定的网址，就能让代码在《江苏快三》和《安徽快三》通用了！
2.如果按期号正序抓取数据不方便，可修改代码为从B3指定的最大期号开始，至B2指定的最小期号结束【即全部按期号从大到小的顺序抓取数据】

如此，怎样修改18楼的代码？

mzbao

WYS67 发表于 2018-12-3 08:30
恳请老师按照21楼的要求，修改和完善18楼的代码。

1. Sub Main()
   
2.     Dim StDate As Date, EndDate As Date, tempDate As Date, ShengFen$
   
3.     Dim rsArr()
   
4.    
   
5.     Range("A5:C" & Cells(Rows.Count, 1).End(xlUp).Row + 1).ClearContents
   
6.    
   
7.     ShengFen = [B1].Value
   
8.     ShengFen = Mid(ShengFen, InStrRev(ShengFen, "/") + 1)
   
9.     ShengFen = Left(ShengFen, InStr(ShengFen, "k3.") - 1)
   
10. 
    
11.     StDate = Format("20" & Left([B2].Value, 6), "0000/00/00")
    
12.     EndDate = Format("20" & Left([B3].Value, 6), "0000/00/00")
    
13.    
    
14.     tempDate = EndDate
    
15.     Do
    
16.         rsArr = getDataFromWebByDate(tempDate, ShengFen)
    
17.         Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1).Resize(UBound(rsArr), 3) = rsArr
    
18.         tempDate = tempDate - 1
    
19.     Loop Until tempDate < StDate
    
20.    
    
21. End Sub
    
22. 
    
23. Function getDataFromWebByDate(dDate As Date, ShengFen As String)
    
24.     Dim strText As String, arr, brr, rsArr(), i%, j%
    
25.    
    
26.     With CreateObject("MSXML2.XMLHTTP")
    
27.         .Open "GET", "http://kaijiang.500.com/static/info/kaijiang/xml/" & ShengFen & "k3/" & Format(dDate, "yyyymmdd") & ".xml", False
    
28.         .Send
    
29.         strText = .responsetext
    
30.     End With
    
31.    
    
32.     If InStr(strText, "404 Not Found") Then
    
33.         ReDim rsArr(1 To 1, 1 To 3)
    
34.         GoTo TheEnd
    
35.     End If
    
36.    
    
37.     strText = Replace(strText, " expect=""", "|")
    
38.     strText = Replace(strText, """ opencode=""", "|")
    
39.     strText = Replace(strText, """ opentime=""", "|")
    
40.     strText = Replace(strText, Chr(10), "")
    
41.     strText = Replace(strText, """               />", "")
    
42.    
    
43.     arr = Split(strText, "<row")
    
44. 
    
45.     ReDim rsArr(1 To UBound(arr), 1 To 3)
    
46.     For i = 1 To UBound(arr)
    
47.         brr = Split(arr(i), "|")
    
48.         rsArr(i, 1) = brr(1)
    
49.         rsArr(i, 2) = brr(3)
    
50.         rsArr(i, 3) = brr(2)
    
51.     Next
    
52. TheEnd:
    
53.     getDataFromWebByDate = rsArr
    
54. End Function

复制代码

WYS67

Kaohsing 发表于 2018-12-3 08:40
这种大概就属于io密集型。

坦白说，我对VBA纯属小白一个，只是知道能够解决用函数公式无法解决的问题。还请老师帮忙则个！