1

Topic: Code optimization Vba

There is a program, which  a site. It works well, but too long. I want it to simplify / to accelerate. Prompt please, can be eat any specialized sites on this question? To any helps I will be grateful.
Program essence:
1. At first on a hyperlink the program comes on a site where finds the certain table of elements
2. Then gets href each element, transforms it into a hyperlink, and interposes in Excel into 1st table
3. Then gets the text of each element and interposes in Excel into 2nd table
4. Then sorts out elements of 1st and 2nd tables that in 3 table each element comprised a hyperlink +
[spoiler]

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) = "List1"
sheetNames (2) = "List2"
sheetNames (3) = "List3"
sheetNames (4) = "List4"
sheetNames (5) = "List5"
sheetNames (6) = "List6"
sheetNames (7) = "List7"
sheetNames (8) = "List8"
sheetNames (9) = "List9"
sheetNames (10) = "List10"
sheetNames (11) = "List11"
sheetNames (12) = "List12"
sheetNames (13) = "List13"
sheetNames (14) = "List14"
sheetNames (15) = "List15"
sheetNames (16) = "List16"
sheetNames (17) = "List17"
sheetNames (18) = "List18"
sheetNames (19) = "List19"
' we pass an error
Set book1 = Workbooks. Open ("E:\Super M\ \ \ 7 \conditions for anderdogov\6.xlsm")
iLoop =-1
With book1.Worksheets ("List1").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
' for a hyperlink
' 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
' !!!! For the text
' 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
' !!!!! A cycle for +
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

[/spoiler]

2

Re: Code optimization Vba

maxim863 wrote:

a program Essence:
1. At first on a hyperlink the program comes on a site where finds the certain table of elements
2. Then gets href each element, transforms it into a hyperlink, and interposes in Excel into 1st table
3. Then gets the text of each element and interposes in Excel into 2nd table
4. Then sorts out elements of 1st and 2nd tables that in 3 table each element comprised a hyperlink +

It was more reasonable to specify it in the code, comments. Even more reasonably - to specify And in the code.
Well it is fine...
1) What of these stages brakes?
2) whether first two tables are Really necessary? Why not to save up all data in storage and directly there to process?

3

Re: Code optimization Vba

All intermediate calculations/searches/fillings to carry out in .
Final data migration in Excel through CopyFromRecordset.

4

Re: Code optimization Vba

Akina, First two tables are not necessary. About to save up all data in storage and directly there to process, and wanted to make. Simply not absolutely I understand, how.

5

Re: Code optimization Vba

big-duke it is made wrote. Drive the data in untied , and then all stored given by a uniform move throw out on sheet.
Well or it is absolutely simple - declare dynamic array, and interpose directly into it. And then simply copy it in the necessary range of sheet.

6

Re: Code optimization Vba

Akina;
Can write a minimum example how to throw the data in recordset (from this that I found: "For tabular object Recordset in a Microsoft Jet database as a source the instructions only a table name") are admitted. And as it competently to write down - I can not find.