宏突然不能用了，大神帮看看是什么问题

清风寒雪

这是一个抓取基金历史净值的宏，之前一直好好的，但在前天突然不能用了，提示“应用程序定义或对象定义错误”，换一台电脑后一运行宏后EXCEL就崩溃重启了，EXCEL重启后再运行就提示“拒绝访问”，在本地窗口查看brr，里面的值都是空值，不知道是网页更改了还是其他什么问题。希望大神们帮帮看看是什么问题导致的，如果肯花费时间帮忙在每行代码后写下注释就更好了。
Sub aa()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Cells.Clear
Dim url As String, i As Long, j As Long, n As Long, s() As String, t() As String, brr(1 To 10000, 1 To 7) As String, cel As Range, reg As Object, str As String
str = InputBox("请输入代码", "提示", 180031)
Set reg = CreateObject("VBSCRIPT.REGEXP")
    reg.Global = True
    reg.Pattern = "</td><td[^>]*[>]"
   
Dim p%
For p = 1 To 85


url = "http://fund.eastmoney.com/f10/F10DataApi.aspx?type=lsjz&code=" & str & "&page=" & p & "&per=2000"
With CreateObject("Microsoft.XMLHTTP")
    .Open "GET", url, True
    .send
While .ReadyState <> 4
    DoEvents
Wend

s = Split(Replace(.responsetext, "</td></tr>", ""), "<tr><td>")
For i = 1 To UBound(s)
     t = Split(reg.Replace(s(i), " "))
     n = n + 1
    For j = 1 To 7
        brr(n, j) = t(j - 1)
Next: Next: End With

Next


[a1:H1] = Split("序号 净值日期 单位净值(元) 累计净值(元) 日增长率 申购状态 赎回状态 分红送配 ")
[b2].Resize(n, 7) = brr
Set reg = Nothing
m = [b65536].End(3).Row
For Each cel In Range("a2:a" & m)
cel = cel.Row - 1
Next
    With Columns("A:g")
        .EntireColumn.AutoFit
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
For Each cel In Range("c2:e" & m)
    cel.Value = cel.Value
    cel.Style = "Comma"
    cel.NumberFormatLocal = "_ * #,##0.0000_ ;_ * -#,##0.0000_ ;_ * ""-""????_ ;_ @_ "
Next
Range("e2:e" & m).NumberFormatLocal = "0.00%"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "ok"
End Sub

清风寒雪

不要沉了啊...

microyip

因为.responsetext得到的是空值

清风寒雪

microyip 发表于 2020-10-27 19:32
因为.responsetext得到的是空值

这个一般是什么问题导致的呢？这个宏是一直用的，之前一直都可以，我也把URL直接输入浏览器看了，能打开，.responsetext好像是以字符串格式返回网页吧，如果URL能正常找开应该不会返回空值的吧。大神能否帮改下？

microyip

换个读取方式

1. CreateObject("msXML2.ServerXMLHttp")

复制代码

microyip

技痒，重编了一下

1. Sub GetUrlData()
   
2.     Dim sURL As String, sCode As String, oRegExp As Object, nPage As Long, nPages As Long, nRecords As Long, sResponseText As String
   
3.     Dim vData As Variant, nI As Long, nJ As Long, oReg As Object, vFill As Variant, nRow As Double, nCol As Long
   
4.    
   
5.     Application.ScreenUpdating = False
   
6.     Application.DisplayAlerts = False
   
7.     Cells.Clear
   
8.     sCode = InputBox("请输入代码", "提示", 180031)
   
9.     Set oRegExp = CreateObject("VBSCRIPT.REGEXP")
   
10.     oRegExp.Global = True
    
11.    
    
12.     nPage = 1
    
13.     sURL = "http://fund.eastmoney.com/f10/F10DataApi.aspx?type=lsjz&code=" & sCode & "&page=[Page]&per=2000"
    
14.     With CreateObject("msXML2.ServerXMLHttp")
    
15.         Do While nPage = 1 Or nPage <= nPages
    
16.             .Open "GET", Replace(sURL, "[Page]", nPage), True
    
17.             .Send
    
18.             While .ReadyState <> 4
    
19.                 DoEvents
    
20.             Wend
    
21.                
    
22.             sResponseText = .ResponseText
    
23.             With oRegExp
    
24.                 If nPages = 0 Then
    
25.                     .Pattern = "records[^\d]+(\d+)[^\d]+pages[^\d]+(\d+)"
    
26.                     Set oReg = .Execute(sResponseText)
    
27.                     If oReg.Count > 0 Then
    
28.                         nRecords = Val(oReg(0).SubMatches(0))
    
29.                         nPages = Val(oReg(0).SubMatches(1))
    
30.                     End If
    
31.                     .Pattern = "<th([^>]+)?>([^<]+)<"
    
32.                     Set oReg = .Execute(sResponseText)
    
33.                     If oReg.Count > 0 Then
    
34.                         ReDim vFill(1 To nRecords + 1, 1 To oReg.Count + 1)
    
35.                         vFill(1, 1) = sCode
    
36.                         For nCol = 1 To oReg.Count
    
37.                             vFill(1, nCol + 1) = oReg(nCol - 1).SubMatches(1)
    
38.                         Next
    
39.                     End If
    
40.                     nCol = 8
    
41.                     nRow = 1
    
42.                     .Pattern = "<td([^>]+)?>([^<]+)?<"
    
43.                 End If
    
44.                 Set oReg = .Execute(sResponseText)
    
45.                 If oReg.Count > 0 Then
    
46.                     nI = 0
    
47.                     Do While nI + 1 < oReg.Count
    
48.                         sCode = oReg(nI).SubMatches(1)
    
49.                         If sCode Like "*-*-*" Then
    
50.                             nCol = 2
    
51.                             nRow = nRow + 1
    
52.                             vFill(nRow, 1) = nRow - 1
    
53.                         Else
    
54.                             nCol = nCol + 1
    
55.                         End If
    
56.                         vFill(nRow, nCol) = oReg(nI).SubMatches(1)
    
57.                         nI = nI + 1
    
58.                     Loop
    
59.                 End If
    
60.             End With
    
61.             nPage = nPage + 1
    
62.         Loop
    
63.     End With
    
64.    
    
65.     With [A1].Resize(UBound(vFill), UBound(vFill, 2))
    
66.         .Offset(, 1).Resize(, 1).NumberFormatLocal = "yyyy-m-d"
    
67.         .Offset(, 2).Resize(, 2).NumberFormatLocal = "_ * #,##0.0000_ ;_ * -#,##0.0000_ ;_ * ""-""????_ ;_ @_ "
    
68.         .Offset(, 4).Resize(, 1).NumberFormatLocal = "0.00%"
    
69.         .Formula = vFill
    
70.         .EntireColumn.AutoFit
    
71.         .HorizontalAlignment = xlCenter
    
72.         .VerticalAlignment = xlBottom
    
73.     End With
    
74.     Application.ScreenUpdating = True
    
75.     Application.DisplayAlerts = True
    
76.     MsgBox "ok"
    
77. End Sub

复制代码

microyip

附上附件以供参考

清风寒雪

microyip 发表于 2020-10-27 23:42
附上附件以供参考

太谢谢了，我再学习下看看两个读取方式有什么不同。

清风寒雪

microyip 发表于 2020-10-27 23:41
技痒，重编了一下

大神好，我把第8行代码改为循环赋值后，第48号代码总是报错“无效的过程调用或参数”，请问是什么原因呢？代码注释请忽视，我网上查的一些资料推测的，不知道是不是正确

CNATB

microyip 发表于 2020-10-27 23:42
附上附件以供参考

太牛了，但记录多了速度好像有点慢，能有更好的解决速度方法吗