VBAコードを最適化する

Question

ウェブサイトを解析するプログラムがあります。プログラムはうまくいくが、長すぎる。私はそれを単純化/スピードアップしたいと思う。私に教えてください。おそらく、この問題に特化したサイトがありますか？どんな助けでも私は感謝します。プログラムの仕組み

：

1. まず、ハイパーリンクによって、プログラムは、それが要素

2. の特定のテーブルを見つけたサイトに行くそれからの「HREF」を取り出し、各要素は、ハイパーリンクに変換します、そして

3. そして1番目のテーブルでExcelに挿入し、それは各要素のテキストを抽出し、2番目のテーブルでExcelに挿入

4. 3-RDテーブルの各要素は、「ハイパーリンク+テキスト」を含むように、それは数があり

   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

、1番目の要素と2番目のテーブルを経由効率を改善するためにできることだが、それはおそらく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をインストールすることを検討すべきです、より多くの提案と最適化が提供され、読みやすさを向上させるためにコードを自動的にインデントします。