Optimizing the Vba code - vba

Question

There is a program ,that parsing website . Program works well , but too long . I want to simplify/speed it up. Tell me please ,maybe there are any specialized sites on this issue ? For any help I will be grateful .
How program works:
First , by the hyperlink , the program goes to the site , where it finds a certain table of elements
Then it takes out the “href” of each element , turns it into a hyperlink , and inserts it into Excel in the 1-st table
Then it extracts the text of each element and inserts it into Excel in the 2-nd table
Then it goes through the elements of the 1-st and 2-nd tables , so that in the 3-rd table each element contains a “hyperlink +text”
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

There are number of things that could be done to improve efficiency, but that is probably better conducted on CodeReview.
I will make mention, however, of your use of late-bound variables. You'll achieve much faster performance with early-binding:
'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
You should also consider installing the free, open-source Rubberduck VBA add-in for the Visual Basic Editor (disclaimer - I'm a contributor), which will come with many more suggestions and optimizations for you, and it will automatically indent your code for improved readability.