我有一个 VBA 脚本,可以让我计算两个城市之间的公里距离:
这个脚本工作正常,问题是我得到的要计算的城市列表超过 5000 个城市。
当我按下“开始”按钮时,处理开始,Excel 文件卡住,在处理完成之前无法查看处理进度,大约需要 1 小时......
是否可以提高我的脚本的处理速度,还是因为我的互联网连接速度?
由于处理时间过长,脚本从大约 3000 个城市停止。我该如何解决这个问题?
Option Explicit
Public Const DIST = "http://www.distance2villes.com/recherche?source="
Sub Distance()
Dim lg As Integer, i As Integer
Dim Url As String, Txt As String
With Sheets("Feuil1")
lg = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lg
Url = DIST & .Range("A" & i).Value & "&destination=" & .Range("B" & i).Value
With CreateObject("WINHTTP.WinHTTPRequest.5.1")
.Open "GET", Url, False
.send
Txt = .responseText
End With
' Only set the value if we got a response
If Txt <> vbNullString Then .Range("C" & i).Value = Split(Split(Txt, "id=""distanciaRuta"">")(1), "</strong>")(0)
' Clear our variable before next
Txt = vbNullString
Next i
End With
End Sub
最佳答案
GetElementById(与双拆分)
MSXML2.XMLHTTP
) 将效率提高了大约 10%。 代码
Option Explicit
Sub Distance()
Const DIST1 As String = "http://www.distance2villes.com/recherche?source="
Const DIST2 As String = "&destination="
Const DIST3 As String = "distanciaRuta"
Const wsName As String = "Feuil1"
'Dim w As Object: Set w = CreateObject("WINHTTP.WinHTTPRequest.5.1")
Dim w As Object: Set w = CreateObject("MSXML2.XMLHTTP")
Dim h As Object: Set h = CreateObject("htmlfile")
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(wsName)
Dim rg As Range
Set rg = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset(, 1))
Dim Data As Variant: Data = rg.Value
Dim isFound As Boolean: isFound = True
Dim i As Long
Dim Url As String
Dim S As String
For i = 1 To UBound(Data, 1)
If Len(Data(i, 1)) > 0 And Len(Data(i, 2)) > 0 Then
Url = DIST1 & Data(i, 1) & DIST2 & Data(i, 2)
w.Open "GET", Url, False
w.Send
h.body.innerHTML = w.responseText
On Error GoTo NotFoundError
S = h.getElementById(DIST3).innerText
On Error GoTo 0
If isFound Then
Data(i, 1) = Replace(Left(S, Len(S) - 3), ",", "")
Else
Data(i, 1) = ""
isFound = True
End If
Else
Data(i, 1) = ""
End If
Next
rg.Columns(1).Offset(, 2).Value = Data
Exit Sub
NotFoundError:
isFound = False
Resume Next
End Sub
关于excel - 如何使用网站加快 VBA 脚本的处理速度?,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/66616878/