[已解决]求帮忙修改下网数据采集格式,代码已有,求修改:

chulia_wong

求帮忙修改下网数据采集格式,代码已有,求修改:感激不尽!
!!!只要显示黄色背景的数据,其它的通通不要;然后把黄色数据倒序发送到单元格(模拟结果)!!!!

最佳答案

月排行榜 / 总排行榜

ghostjiao

2015-10-25 19:10

1. Sub demo()
   
2.     Dim url$, str$, arr, nr, i%, brr, m%, n%, j%
   
3.     Application.ScreenUpdating = False
   
4.     url = "http://www.17500.cn/getData/ssq.TXT"
   
5.     With CreateObject("MSXML2.XMLHTTP")
   
6.         .Open "GET", url, False
   
7.         .send
   
8.         str = .responsetext
   
9.         arr = Split(str, Chr(10))
   
10.         ReDim brr(1 To UBound(arr), 1 To 8)
    
11.         For i = UBound(arr) - 1 To 0 Step -1
    
12.             m = m + 1
    
13.             nr = Split(arr(i), " ")
    
14.             n = 0
    
15.             For j = 0 To 8
    
16.                 If j <> 1 Then
    
17.                     n = n + 1
    
18.                     brr(m, n) = nr(j)
    
19.                 End If
    
20.             Next
    
21.         Next
    
22.     End With
    
23.     Sheets("模拟结果").Range("A3").Resize(UBound(brr), 8) = brr
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

跳转到最佳答案楼层

ghostjiao

1. Sub demo()
   
2.     Dim url$, str$, arr, nr, i%, brr, m%, n%, j%
   
3.     Application.ScreenUpdating = False
   
4.     url = "http://www.17500.cn/getData/ssq.TXT"
   
5.     With CreateObject("MSXML2.XMLHTTP")
   
6.         .Open "GET", url, False
   
7.         .send
   
8.         str = .responsetext
   
9.         arr = Split(str, Chr(10))
   
10.         ReDim brr(1 To UBound(arr), 1 To 8)
    
11.         For i = UBound(arr) - 1 To 0 Step -1
    
12.             m = m + 1
    
13.             nr = Split(arr(i), " ")
    
14.             n = 0
    
15.             For j = 0 To 8
    
16.                 If j <> 1 Then
    
17.                     n = n + 1
    
18.                     brr(m, n) = nr(j)
    
19.                 End If
    
20.             Next
    
21.         Next
    
22.     End With
    
23.     Sheets("模拟结果").Range("A3").Resize(UBound(brr), 8) = brr
    
24.     Application.ScreenUpdating = True
    
25. End Sub
    

复制代码

chulia_wong

ghostjiao 发表于 2015-10-25 19:10

太谢谢你了.真是高手在民间.等了一天没人会,终于等来了高手!