Question

有一个解析网站的程序。程序运行良好，但时间太长。我想简化/加速它。请告诉我，也许在这个问题上有任何专门的网站？如有任何帮助，我将不胜感激。

程序如何运作：

首先，通过超链接，程序进入网站，在那里找到某个元素表
然后取出每个元素的“href”，将其转换为超链接，然后将其插入到第一个表格的Excel中
然后它提取每个元素的文本并将其插入到第二个表中的Excel

然后它遍历1-st和2-nd表的元素，这样在第3个表中每个元素都包含一个“超链接+文本”

 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上进行。

但是，我会提到你使用后期变量。通过早期绑定，您将获得更快的性能：

'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加载项（免责声明 - 我的贡献者），它将为您提供更多建议和优化，它将会自动缩进代码以提高可读性。

优化Vba代码

1 个答案: