请问大家能帮助看下那代码为什么不能下载全部的数据？

westwindgg

急，如附件，原来运行正常，现在一运行，只能下载20多页就停止了，请大家指点下。

westwindgg

1. Sub CFDA()
   
2. 
   
3.     Dim htm As String, htm2 As String, i As Long, j As Long, p As Long, v() As String, title, arr() As String
   
4. 
   
5.     title = Split("注册证号,原注册证号,注册证号备注,分包装批准文号,公司名称（中文）,公司名称（英文）,地址（中文）,地址（英文）,国家/地区（中文）,国家/地区（英文）,产品名称（中文）,产品名称（英文）,商品名（中文）,商品名（英文）,剂型（中文）,规格（中文）,包装规格（中文）,生产厂商（中文）,生产厂商（英文）,厂商地址（中文）,厂商地址（英文）,厂商国家/地区（中文）,厂商国家/地区（英文）,发证日期,有效期截止日,分包装企业名称,分包装企业地址,分包装文号批准日期,分包装文号有效期截止日,产品类别,药品本位码,药品本位码备注", ",")
   
6. 
   
7.   
   
8.     [b1:ag1] = title
   
9. 
   
10.     With CreateObject("microsoft.xmlhttp")
    
11. 
    
12.         For p = 1 To 1000
    
13. 
    
14.             .Open "get", "http://app1.sfda.gov.cn/datasearch/face3/search.jsp?tableId=36&tableName=TABLE36&bcId=124356651564146415214424405468&curstart=" & p, False
    
15. 
    
16.             .send
    
17. 
    
18.             Do While Not .ReadyState = 4
    
19. 
    
20.                 DoEvents
    
21. 
    
22.             Loop
    
23. 
    
24.             htm = .responsetext
    
25. 
    
26.             v = Filter(Split(htm, "'"), "content.jsp?tableId=36&tableName=TABLE36&tableView=进口药品&Id=")
    
27. 
    
28.             ReDim arr(UBound(v), 32)
    
29. 
    
30.             For i = 0 To UBound(v)
    
31. 
    
32.                 arr(i, 0) = Split(Split(Split(htm, v(i))(1), ">")(1), "<")(0)
    
33. 
    
34.                 .Open "get", "http://app1.sfda.gov.cn/datasearch/face3/" & v(i), False
    
35. 
    
36.                 .send
    
37. 
    
38.                 Do While Not .ReadyState = 4
    
39. 
    
40.                     DoEvents
    
41. 
    
42.                 Loop
    
43. 
    
44.                 htm2 = Replace(Replace(.responsetext, """>", "%>"), "</a>", "")
    
45. 
    
46.                 For j = 1 To 32
    
47. 
    
48.                     arr(i, j) = Split(Split(Split(htm2, title(j - 1) & "</td>")(1), "%>")(1), "</td></tr>")(0)
    
49. 
    
50.                 On Error Resume Next
    
51.                 Next
    
52.                
    
53. 
    
54.             Next
    
55. 
    
56.              [a65536].End(3).Offset(1, 0).Resize(UBound(v) + 1, 33) = arr
    
57. 
    
58.         Next
    
59. 
    
60. 
    
61. 
    
62.     End With
    
63. 
    
64. 
    
65. 
    
66. End Sub
    
67. 
    

复制代码

westwindgg

再次求助大家！有人能指点下吗？

westwindgg

再次求助！