Копирование ссылки с веб-страницы

Sub ЗагрузкаСпискаНомеровExcel()
     Dim CStart As Range, BaseStart As Range, Firm$, Mail$, Face$, Ex$, NotEx$, Success As Boolean
Dim yBase&
Dim ra As Range, cell As Range, n As Long: On Error Resume Next
Set CStart = Sheets(3).[A4] 'реестровые номера заказа с листа № 3 (ячейка А4)
     
 
    For i = 1 To 10
         ' формируем ссылку
        URL$ = "http://zakupki.gov.ru/pgz/public/action/search/quick/run?currentSearchString=" & i - после равно должно вставляться поле с реестровым номером заказа (А4) и так по порядку, потом надо чтобы копировался текст ссылки на заказ
 
        Set ra = GetQueryRange(URL$, 6)    ' выполняем веб-запрос
 
        ' перебирая ячейки таблицы-результата, выводим список тем в окно Immediate
        For Each cell In ra.Columns(2).Cells
             If cell.Hyperlinks.Count Then
                 n = n + 1: Debug.Print "Тема №" & n, cell.Text
                 Debug.Print "Ссылка на тему: " & cell.Hyperlinks(1).Address: Debug.Print
             End If
         Next cell
     Next i
 End Sub
Function GetQueryRange(ByVal SearchLink$, Optional ByVal Tables$) As Range
     On Error Resume Next: Err.Clear
     Dim tmpSheet As Worksheet: Set tmpSheet = ThisWorkbook.Worksheets("tmpWQ")
     If tmpSheet Is Nothing Then
         Application.ScreenUpdating = False
         Set tmpSheet = ThisWorkbook.Worksheets.Add
         tmpSheet.Name = "tmpWQ1"
         tmpSheet.Visible = xlSheetVeryHidden
     End If
     If tmpSheet Is Nothing Then
         msg$ = "Не удалось добавить скрытый лист «tmpWQ1» в файл программы"
         MsgBox msg, vbCritical, "Невозможно выполнить запрос к сайту": End
     End If
 
    tmpSheet.Cells.Delete: DoEvents: Err.Clear
     With tmpSheet.QueryTables.Add("URL;" & SearchLink$, tmpSheet.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: DoEvents
         If Err = 0 Then Set GetQueryRange = tmpSheet.UsedRange
         .Delete: DoEvents
     End With
 End Function

         ' формируем ссылку
        URL$ = "http://zakupki.gov.ru/pgz/public/action/search/quick/run?currentSearchString=" & Right(ThisWorkbook.Sheets(3).Cells(3 + i, 1), 19)
        '- после равно должно вставляться поле с реестровым номером заказа (А4) и так по порядку, потом надо чтобы копировался текст ссылки на заказ
 
        Set ra = GetQueryRange(URL$, "3")    ' выполняем веб-запрос
 
        ' перебирая ячейки таблицы-результата, выводим список тем в окно Immediate
        For Each oCell In ra.Columns(7).Cells
             If oCell.Hyperlinks.Count Then
                 n = n + 1: Debug.Print "Тема №" & n, oCell.Text
                 Debug.Print "Ссылка на тему: " & oCell.Hyperlinks(1).Address: Debug.Print
             End If
         Next oCell
         ra.Range("G22").Copy
         With ThisWorkbook.Sheets(3)
            .Activate
            With .Cells(3 + i, "J")
                .Select
                 ActiveSheet.Paste
                .HorizontalAlignment = xlLeft
                .WrapText = False
                .Value = ra.Range("G22").Hyperlinks(1).Address
            End With
         End With

For i = 1 To ThisWorkbook.Sheets("Лист3").Range("A4").CurrentRegion.End(xlDown) - 3

 For i = 1 To ThisWorkbook.Sheets("Лист3").Range("A4").CurrentRegion.End(xlDown) - 4
 
        ' формируем ссылку
        ' Сайт и поисковый запрос к сайту.
        'Синтаксис построения запроса определяется поисковой машиной сайта
        URL$ = "http://zakupki.gov.ru/pgz/public/action/search/quick/run?currentSearchString=" & Right(ThisWorkbook.Sheets("Лист3").Cells(3 + i, 1), 19)
        '- после равно должно вставляться поле с реестровым номером заказа (А4) и так по порядку, потом надо чтобы копировался текст ссылки на заказ
 
        Set ra = GetQueryRange(URL$, "3")    ' выполняем веб-запрос
 
        ' перебирая ячейки таблицы-результата, выводим список тем в окно Immediate
        For Each oCell In ra.Columns(7).Cells
             If oCell.Hyperlinks.Count Then
                 n = n + 1: Debug.Print "Тема №" & n, oCell.Text
                 Debug.Print "Ссылка на тему: " & oCell.Hyperlinks(1).Address: Debug.Print
             End If
        Next oCell
        'Копируем ячейку со ссылкой с листа "tmpWQ1"
        ra.Range("G22").Copy
        With ThisWorkbook.Sheets("Лист3")
           .Activate
           With .Cells(3 + i, "J")
               .Select
               ' вставляем скопированную ячейку на "Лист3"
                ActiveSheet.Paste
                ' Форматирование
               .HorizontalAlignment = xlLeft
               .WrapText = False
               ' Вcтавляемый видимый текст ссылки
               .Value = ra.Range("G22").Hyperlinks(1).Address
           End With
        End With
 
     Next i
 End Sub

For i = 1 To ThisWorkbook.Sheets("Лист3").Range("A4").CurrentRegion.End(xlDown).Row - 3

Sub ЗагрузкаСпискаНомеровExcel()
    Dim CStart As Range, BaseStart As Range, Firm$, Mail$, Face$, Ex$, NotEx$, Success As Boolean
    Dim yBase&
    Dim ra As Range, oCell As Range, n As Long: On Error Resume Next
    With ThisWorkbook.Sheets("Лист3")
        'Нижеследующее присвоение ссылки на объект в данном макросе не используется.
        Set CStart = .[A4] 'реестровые номера заказа с листа № 3 (ячейка А4)
        For i = 1 To .UsedRange.End(xlDown).Row - 3
            If Val(Right(.Cells(3 + i, 1), 19)) > 1 Then
                 ' формируем ссылку
                 ' Сайт и поисковый запрос к сайту.
                 'Синтаксис построения запроса определяется поисковой машиной сайта
                 URL$ = "http://zakupki.gov.ru/pgz/public/action/search/quick/run?currentSearchString=" & Right(.Cells(3 + i, 1), 19)
                 '- после равно должно вставляться поле с реестровым номером заказа (А4) и так по порядку, потом надо чтобы копировался текст ссылки на заказ
                 Set ra = GetQueryRange(URL$, "3")    ' выполняем веб-запрос
                 ' перебирая ячейки таблицы-результата, выводим список тем в окно Immediate
                 For Each oCell In ra.Columns(7).Cells
                      If oCell.Hyperlinks.Count Then
                          n = n + 1: Debug.Print "Тема №" & n, oCell.Text
                          Debug.Print "Ссылка на тему: " & oCell.Hyperlinks(1).Address: Debug.Print
                      End If
                 Next oCell
                'Копируем ячейку со ссылкой с листа "tmpWQ1"
                ra.Range("G22").Copy
                .Activate
                With .Cells(3 + i, "J")
                      .Select
                      ' вставляем скопированную ячейку на "Лист3"
                       ActiveSheet.Paste
                       ' Форматирование
                      .HorizontalAlignment = xlLeft
                      .WrapText = False
                      ' Вcтавляемый видимый текст ссылки
                      .Value = ra.Range("G22").Hyperlinks(1).Address
                End With
            End If
        Next i
    End With
 End Sub