vba - 优化Vba代码

Question

有一个程序，就是解析网站。程序运行良好，但太长。我想简化/加快速度。请告诉我，也许有专门的网站讨论这个问题？对于任何帮助，我将不胜感激。

程序如何工作:

1. 首先，通过超链接，程序转到站点，在那里找到某个元素表

2. 然后取出每个元素的“href”，将其转换为超链接，并将其插入到Excel第一个表中

3. 然后提取每个元素的文本并将其插入到 Excel 的第二个表中

4. 然后遍历第一个和第二个表的元素，以便在第三个表中每个元素包含一个“超链接+文本”

    Sub Softгиперссылки()
     Application.DisplayAlerts = False
   
   
     Call mainмассивы
   
     Application.DisplayAlerts = True
   End Sub
   
   
   Sub mainмассивы()
    Dim r As Range
    Dim firstAddress As String
    Dim iLoop As Long
    Dim book1 As Workbook
    Dim sheetNames(1 To 19) As String
    Dim Ssilka As String
   
   
    sheetNames(1) = "Лист1"
    sheetNames(2) = "Лист2"
    sheetNames(3) = "Лист3"
    sheetNames(4) = "Лист4"
    sheetNames(5) = "Лист5"
    sheetNames(6) = "Лист6"
    sheetNames(7) = "Лист7"
    sheetNames(8) = "Лист8"
    sheetNames(9) = "Лист9"
    sheetNames(10) = "Лист10"
    sheetNames(11) = "Лист11"
    sheetNames(12) = "Лист12"
    sheetNames(13) = "Лист13"
    sheetNames(14) = "Лист14"
    sheetNames(15) = "Лист15"
    sheetNames(16) = "Лист16"
    sheetNames(17) = "Лист17"
    sheetNames(18) = "Лист18"
    sheetNames(19) = "Лист19"
   
    'пропускаем ошибку
   
     Set book1 = Workbooks.Open("E:\Super M\Проект ставки\Поиск решения\Усов 7\Условия для андердогов\6.xlsm")
   
     iLoop = -1
   
    With book1.Worksheets("Лист1").Range("R34:R99")
   
    For Each r In .Rows
        If r.Value = 1 Then
   
           iLoop = iLoop + 1
           Ssilka = r.Offset(, -13).Hyperlinks.Item(1).Address
           .Parent.Parent.Worksheets(sheetNames(1)).Activate
           .Parent.Parent.Save
           extractTable Ssilka, book1, iLoop
   
         End If
     Next r
   
    End With
    book1.Save
    book1.Close
    Exit Sub
   
   
   End Sub
   
   
     Function extractTable(Ssilka As String, book1 As Workbook, iLoop As Long)
     Dim oDom As Object, oTable As Object, oRow As Object
     Dim iRows As Integer, iCols As Integer
     Dim x As Integer, y As Integer
     Dim data()
     Dim oHttp As Object
     Dim oRegEx As Object
     Dim sResponse As String
     Dim oRange As Range
     Dim Perem1 As String
     Dim Perem2 As String
   
   
   
    'для гиперссылки
   
    ' get page
     Set oHttp = CreateObject("MSXML2.XMLHTTP")
     oHttp.Open "GET", Ssilka, False
     oHttp.Send
   
    ' cleanup response
     sResponse = StrConv(oHttp.responseBody, vbUnicode)
     Set oHttp = Nothing
   
    sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
   
    Set oRegEx = CreateObject("vbscript.regexp")
   With oRegEx
   .MultiLine = True
   .Global = True
   .IgnoreCase = False
   .Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
   sResponse = .Replace(sResponse, "")
   End With
   Set oRegEx = Nothing
   
    ' create Document from response
     Set oDom = CreateObject("htmlFile")
     oDom.Write sResponse
     DoEvents
   
     ' table with results, indexes starts with zero
   Set oTable = oDom.getelementsbytagname("table")(3)
   
   DoEvents
   
   iRows = oTable.Rows.Length
   iCols = oTable.Rows(1).Cells.Length
   
   ' first row and first column contain no intresting data
   ReDim data(1 To iRows - 1, 1 To iCols - 1)
   
   ' fill in data array
   For x = 1 To iRows - 1
   Set oRow = oTable.Rows(x)
   
   For y = 1 To iCols - 1
        If oRow.Cells(y).Children.Length > 0 Then
           data(x, y) = oRow.Cells(y).getelementsbytagname("a")(0).getattribute("href")
   
       End If
   
   Next y
    Next x
   
    Set oRow = Nothing
    Set oTable = Nothing
    Set oDom = Nothing
   
     ' put data array on worksheet
   
    Set oRange = book1.ActiveSheet.Cells(110, 26 + (iLoop * 21)).Resize(iRows - 1, iCols - 1)
    oRange.NumberFormat = "@"
    oRange.Value = data
    oRange.Replace What:="about:", Replacement:="http://allscores.ru/soccer/"
    Set oRange = Nothing
   
     '!!!! для текста
   
    ' get page
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    oHttp.Open "GET", Ssilka, False
    oHttp.Send
   
   ' cleanup response
   sResponse = StrConv(oHttp.responseBody, vbUnicode)
   Set oHttp = Nothing
   
   sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))
   
   Set oRegEx = CreateObject("vbscript.regexp")
   With oRegEx
   .MultiLine = True
   .Global = True
   .IgnoreCase = False
   .Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
   sResponse = .Replace(sResponse, "")
   End With
   Set oRegEx = Nothing
   
      ' create Document from response
      Set oDom = CreateObject("htmlFile")
      oDom.Write sResponse
       DoEvents
   
      ' table with results, indexes starts with zero
      Set oTable = oDom.getelementsbytagname("table")(3)
   
      DoEvents
   
      iRows = oTable.Rows.Length
      iCols = oTable.Rows(1).Cells.Length
   
     ' first row and first column contain no intresting data
      ReDim data(1 To iRows - 1, 1 To iCols - 1)
   
      ' fill in data array
      For x = 1 To iRows - 1
      Set oRow = oTable.Rows(x)
   
     For y = 1 To iCols - 1
        If oRow.Cells(y).Children.Length > 0 Then
           data(x, y) = oRow.Cells(y).innerText
   
       End If
   
   Next y
   Next x
   
   Set oRow = Nothing
   Set oTable = Nothing
   Set oDom = Nothing
   
    ' put data array on worksheet
   
   Set oRange = book1.ActiveSheet.Cells(185, 26 + (iLoop * 21)).Resize(iRows - 1, iCols - 1)
    oRange.NumberFormat = "@"
    oRange.Value = data
   
     Set oRange = Nothing
   
     '!!!!! цикл для текст+гиперссылка
   
   
   For A = 0 To 4
   For B = 0 To 65
   
    Perem1 = book1.ActiveSheet.Cells(110 + B, (26 + (iLoop * 21)) + A).Value
    Perem2 = book1.ActiveSheet.Cells(185 + B, (26 + (iLoop * 21)) + A).Value
   
     book1.ActiveSheet.Hyperlinks.Add Anchor:=Cells(34 + B, (26 + (iLoop * 21)) + A), Address:=Perem1, TextToDisplay:=Perem2
    Next
    Next
   
   
   
   End Function
   

Answer 1

可以采取很多措施来提高效率，但这可能在 CodeReview 上进行得更好。

不过，我会提到您对后期绑定(bind)变量的使用。通过早期绑定(bind)，您将获得更快的性能:

'Late-bound variable declaration and creation
Dim oRegExp As Object
Set oRegEx = CreateObject("vbscript.regexp")
With oRegEx
   '....
End With

'Late-bound reference only:
'No variable declaration required, the variable only survives as long as the With Block
With CreateObject("vbscript.regexp")
    '....
End With

'Early-bound - Add a reference to Microsoft VBScript Regular Expressions 5.5
'This is the fastest and most efficient use of a new RegExp object, and you get intellisense in the VBE
With New RegExp
    '....
End With

您还应该考虑为 Visual Basic 编辑器安装免费的开源 Rubberduck VBA 插件(免责声明 - 我是贡献者)，它将为您提供更多建议和优化，并且它会自动缩进代码以提高可读性。