Optimierung des VBA-Codes

Question

Es gibt ein Programm, das die Website analysiert. Programm funktioniert gut, aber zu lang. Ich möchte es vereinfachen/beschleunigen. Sagen Sie mir bitte, vielleicht gibt es spezialisierte Seiten zu diesem Thema? Für jede Hilfe werde ich dankbar sein.

Wie Programm funktioniert:

1. Zuerst durch den Hyperlink, geht das Programm auf der Website, wo es sich um eine bestimmte Tabelle

   von Elementen findet

2. Dann ist es die „href“ nimmt aus jedes Element, verwandelt es in einen Hyperlink, und fügt es in Excel in der 1-st Tabelle

3. extrahiert dann den Text eines jedes Elements und fügt es in Excel in der 2. Tabelle

4. Dann geht es durch die Elemente der 1-st und 2-nd-Tabellen, so daß in der 3. Tabelle jedes Element einen „Hyperlink + Text“ enthält

   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

Es gibt eine Reihe von Dinge, die getan werden könnten, um die Effizienz zu verbessern, aber das ist wahrscheinlich besser auf CodeReview durchgeführt.

Ich werde jedoch erwähnen, dass Sie spät gebundene Variablen verwenden. Sie werden erreichen viel schnellere Leistung mit frühen Bindung:

'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 

Sie sollten auch die freie Open-Source-Rubber VBA-Add-in für Visual Basic-Editor zu installieren (Disclaimer - Ich bin ein Mitwirkender), Das wird mit vielen weiteren Vorschlägen und Optimierungen für Sie kommen, und es wird Ihren Code automatisch einrücken, um die Lesbarkeit zu verbessern.