因此,这与其说是答案,不如说是代码审查。以下是关于您的代码的注释和建议的重写。
使用Long 而不是Integer,因为这样可以降低Integer 数据类型可能发生的溢出风险,尤其是在处理行循环时(行数超过Integer 可以处理的数量)。此外,Integer v Long 对性能没有任何好处。
驼峰局部变量
firstRow
使用工作表变量提高可读性
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
使用显式的工作表引用而不是容易出错的隐式Activesheet 引用。使用上面的ws 变量:
Range("Table6")
具有隐式 Activesheet 引用可以具有显式工作表引用
ws.Range("Table6")
dataList.value 是一个二维数组,因为您正在从工作表中读取一个范围:
For i = 1 To UBound(dataList.Value)
因此,应该在循环中指定第二个维度,将二维数组读入变量会更有效,而不是重复昂贵的 i/o 以获取值
我不知道您的 table6 是什么样的,但我怀疑您正在尝试循环特定列(可能是第一列)
然后,您可以将表放入一个变量中,然后将其第一列值(不包括标题)读入一维数组以进行循环。由于您稍后将再次将值写入工作表,因此将输出数组的维度设置为与您正在循环的数组相同的维度,以将循环的结果存储在
Dim arr(), table As ListObject, output()
Set table = ws.ListObjects("Table6")
arr = Application.Transpose(table.ListColumns(1).DataBodyRange.Value)
ReDim output(1 To UBound(arr))
这个
If IsEmpty(dataList.Value) Then
Exit Sub
Else
基本上是看表databodyrange是否为空。假设您正在检查表的第 1 列中是否有任何 url,那么只需要此测试
在循环之前一次,并且可以是一个没有If Else End If的单衬里@
If IsEmpty(arr) Then Exit Sub
考虑将局部变量重命名为更有用/更具描述性的值:currentValue 到 currentUrl,因为这对 IMO 更有用。
这个
If Len(currentValue) = 0 Then
GoTo ByPass
End If
基本上是检查是否有值作为 url 传递并使用 GoTo 来处理不存在的情况。尽可能避免使用 GoTo,因为它会使代码更难阅读。这里不需要。您可以使用快速的vbNullString 比较,甚至更好的Instr(url, "http") > 0 来验证您将使用的值:
(我已经从 currentValue 切换了)
'initial code
If currentUrl <> vbNullString Then 'test
'call the sub and extract value
End If
n = n + 1 'increment....loop....rinse....repeat
替代验证:
If instr(currentUrl, "http") > 0 Then 'test
'call the sub and extract value
End If
n = n + 1 'increment....loop....rinse....repeat
由于您已经有了i 的循环变量,因此根本不需要n。特别是考虑到以相同索引填充输出数组。
当你有Dim ie As时,ie 已经什么都不是了.....你想在一开始就实例化对象
Set ie = CreateObject("InternetExplorer.Application")
然后在整个循环中使用该实例。您已经在抓取子签名中包含ie,因此预计您将传递相同的实例:
Public Sub MM_description(currentValue As String, n As Long, firstRow As Long, ie As Object)
在签名中添加ByRef、ByVal
Public Sub MM_description(ByVal currentValue As String, ByVal n As Long, ByVal firstRow As Long, ByVal ie As Object)
在调用 sub 时删除多余的 Call 关键字并删除 () 因为这是一个带参数的 sub
Call MM_description(currentValue, n, firstRow, ie) > MM_description currentValue, n, firstRow, ie
当您将ie 传递给子MM_description 时,您不想遵循它并在被调用的子中实例化一个新实例。所以,删除
Set ie = Nothing
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = False
从内部MM_description
在被调用的子里面:
从
中删除
()
ie.Navigate2 (currentUrl)
所以
ie.Navigate2 currentUrl
并使用适当的页面加载等待。所以替换:
Do While ie.Busy
Application.Wait DateAdd("s", 1, Now)
Loop
与
while .busy or .readystate <> 4:wend
删除未使用的变量,例如Dim html As HTMLDocument,并声明所有其他使用的,例如Dim mes As String。将Option Explicit 放在模块顶部以检查变量拼写和声明的一致性。
现在,我实际上会将这个子 MM_description 转换为一个函数,该函数返回抓取的字符串值或 "Not Found",并在调用该函数的同一循环中填充输出数组。
如果现在这是一个函数,签名需要指定返回类型,对函数的调用需要赋值,() 在评估时返回。
output(i) = MM_description(currentUrl, n, firstRow, ie)
最后,将output 数组一次性写入您想要输出值的任何范围。
Worksheets("Input").Range("F1").Resize(UBound(output), 1) = Application.Transpose(output)
上述许多变化会导致如下结构:
Option Explicit
Public Sub LooperForMMDescription()
Dim currentUrl As String, i As Long
Dim ie As Object, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set table = ws.ListObjects("Table6")
Dim arr(), table As ListObject, output()
arr = Application.Transpose(table.ListColumns(1).DataBodyRange.Value)
ReDim output(1 To UBound(arr))
Set ie = CreateObject("InternetExplorer.Application")
If IsEmpty(arr) Then Exit Sub
ie.Visible = True
For i = LBound(arr) To UBound(arr)
currentUrl = arr(i)
If InStr(currentUrl, "http") > 0 Then 'test
'call the sub and extract value
output(i) = MM_description(currentUrl, i, ie)
End If
Next i
ie.Quit
ThisWorkbook.Worksheets("Input").Range("F1").Resize(UBound(output), 1) = Application.Transpose(output)
End Sub
Public Function MM_description(ByVal currentUrl As String, ByVal i As Long, ByVal ie As Object) As String
Dim codeLine As String, startPos As Long, endPos As Long, mes As String
With ie
.Navigate2 currentUrl
While .Busy Or .readyState < 4: DoEvents: Wend
mes = .document.body.innerHTML
startPos = InStr(mes, "Description") + 61
endPos = InStr(mes, "Address")
If startPos = 0 Then
MM_description = "Not Found"
Else
codeLine = Mid$(mes, startPos, endPos - startPos - 229)
MM_description = codeLine
End If
End With
End Function