Итак, это скорее обзор кода, чем ответ.Ниже приведены примечания к вашему коду и рекомендуемая перезапись.
Используйте Long, а не Integer, поскольку это снижает риск переполнения, который может произойти с типом данных Integer, особенно при работе сциклы строк (больше строк, чем может обработать Integer).Кроме того, здесь нет никакого выигрыша в производительности от Integer v Long.
Локальных переменных Camelcase
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)
Итак, в вашем цикле должно быть указано второе измерение, и было бы более эффективно считывать этот 2-мерный массив в переменную, а не подвергатьсяповторяющиеся дорогостоящие операции ввода-вывода при выходе на лист для значения
Я не знаю, как выглядит ваш 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))
This
If IsEmpty(dataList.Value) Then
Exit Sub
Else
в основном проверяет, является ли таблица данных пустой.Предполагая, что вы проверяете, есть ли какие-либо URL-адреса в столбце 1 вашей таблицы, этот тест необходим только один раз перед циклом и может быть однострочным без 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 на самом деле вообще не требуется.Особенно в свете заполнения выходного массива с такими же индексами.
ie - это уже ничто, когда у вас есть Dim ie As ..... Вы хотите создать экземпляр объекта в начале
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)
Удалите лишнее ключевое слово Call при вызове подпрограммы и удалите (), так как это подпрограмма с параметрами
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