Загрузка информации с сайта

Sub Загрузка()
     
    
    Dim ra As Range, oCell As Range, n As Long: On Error Resume Next
    
    ' В данном файле лист № 3 - имеет имя "Лист2".
    'Debug.Print Sheets(3).Name
    
  
         ' формируем ссылку
        URL$ = "http://www.sberbank-ast.ru/SupplierList.aspx"
 
        Set ra = GetQueryRange(URL$)     ' выполняем веб-запрос
 
        ' перебирая ячейки таблицы-результата, выводим список тем в окно Immediate
       
             
         
         ra.Range("G22").Copy
         With ThisWorkbook.Sheets(4)
            .Activate
            With .Cells(3 + i, "J")
                .Select
                 ActiveSheet.Paste
                .HorizontalAlignment = xlLeft
                .WrapText = False
                .Value = ra.Range("G22").Hyperlinks(1).Address
            End With
         End With
 
       
 End Sub
 
Function GetQueryRange(ByVal SearchLink$, Optional ByVal Tables$) As Range
    On Error Resume Next: Err.Clear  '###
    Dim tmpSheet As Worksheet, tmpSh As Worksheet
     
    With ThisWorkbook
        For Each tmpSh In .Worksheets
            If tmpSh.Name = "tmpWQ1" Then
                Set tmpSheet = tmpSh
                Exit For
            End If
        Next tmpSh
         
         If tmpSheet Is Nothing Then
            Application.ScreenUpdating = False
            Set tmpSheet = .Worksheets.Add
            tmpSheet.Name = "tmpWQ1"
            tmpSheet.Visible = xlSheetVeryHidden '###
         End If
     End With
     If tmpSheet Is Nothing Then
         msg$ = "Не удалось добавить скрытый лист «tmpWQ1» в файл программы"
         MsgBox msg, vbCritical, "Невозможно выполнить запрос к сайту": End
     End If
     With tmpSheet
       '.Activate  '###
       .Cells.Delete: DoEvents: Err.Clear
         With .QueryTables.Add("URL;" & SearchLink$, .Range("A1"))
             If Len(Tables$) Then
                 .WebSelectionType = xlSpecifiedTables
                 .WebTables = Tables$
             Else
                 .WebSelectionType = xlEntirePage
             End If
             .FillAdjacentFormulas = False: .PreserveFormatting = True
             .RefreshOnFileOpen = False: DoEvents
             .WebFormatting = xlWebFormattingAll
             .Refresh BackgroundQuery:=False
        End With
    End With
    If Err = 0 Then Set GetQueryRange = tmpSheet.UsedRange
 End Function

Sub proga()
Dim ie As New InternetExplorer
Dim objCollection As Object
ie.navigate "http://www.sberbank-ast.ru/SupplierList.aspx"
'ie.Visible = True
Do
DoEvents
Loop Until ie.readyState = READYSTATE_COMPLETE
Dim Doc As HTMLDocument
Dim Doc2 As HTMLDocument
Set Doc = ie.document
Dim  tr As Long, td As Long, i As Long, k As Long
 
 Set objCollection = Doc.getElementsByTagName("table")(2).getElementsByTagName("tr")
 tr = objCollection.Length
 td = objCollection(0).getElementsByTagName("td").Length
 
Range("i1") = tr
For i = 1 To tr - 1
    For k = 1 To td
    Лист2.Cells(i, k) = objCollection(i).getElementsByTagName("td")(k - 1).innerText
    Next k
Next i
 
ie.Quit
 
End Sub