Encoded = WorksheetFunction.EncodeURL("Россия, Еврейская Аобл, Ленинский р-н, ст Ленинск, ул Красноармейская,д.52")
    With CreateObject("Microsoft.XMLHTTP")
        .Open "GET", "https://indexphone.ru/?search=" & Encoded, "False"
        .SetRequestHeader "Content-Type", "text/html; charset=utf-8"
        .Send
        If .StatusText = "OK" Then
            Response = .ResponseText
            result = Split(Split(Response, "post-search-list-postalcode"">")(1), "</")(0)
            Cells(1, 1) = result
        End If
    End With

With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
     .SetText ActiveCell.Text
     .PutInClipboard
End With

Private Sub SaveToPDF()
    With ActiveSheet.Range("A1:I17")
        If Not Application.GetSaveAsFilename(ActiveSheet.Name, "PDF (*.pdf), *.pdf") Then
            .ExportAsFixedFormat Type:=xlTypePDF, Filename:=(SAF), Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, From:=1, To:=1, OpenAfterPublish:=False
            'CreateObject("Shell.Application").Explore (Left(SAF, InStrRev(SAF, "\"))) 'раскомментировать строку, если необходимо открывать указанную папку после сохранения
        End If
    End With
End Sub

EXEC [adm].[dbo].[mp_g_p_moo_mono_i] 'ALL'

        With CreateObject("msxml2.xmlhttp")
            .Open "GET", URL, True
            .send
            Do: DoEvents: Loop Until .readyState = 4
            t = .responseText
            arr = dann(t)
            If Not IsEmpty(arr) Then
                For j = 0 To UBound(arr)
                    Cells(i, 7 + j) = "http:" & arr(j)
                Next
            Else
                Cells(i, 7) = "нет картинки"
            End If
        End With

    With CreateObject("VBScript.RegExp")
        .IgnoreCase = True
        .Global = True
        .MultiLine = True
        .Pattern = "data-fancybox-group=(.*?) href=""(.*?)"""
        If .Test(t) Then
            Set Matches = .Execute(t)
            ReDim arr(Matches.Count - 1)
            For i = 0 To Matches.Count - 1
                arr(i) = Matches(i).SubMatches(1)
            Next
            dann = arr
            Set Matches = Nothing
        End If
    End With

     Set REGEXP = CreateObject("VBScript.RegExp")
     REGEXP.IgnoreCase = True
     REGEXP.Global = True
     REGEXP.MultiLine = True
     REGEXP.Pattern = "data-fancybox-group=(.*?) href=""(.*?)"""
     If REGEXP.Test(t) Then
        Set Matches = REGEXP.Execute(t)
        Set List = CreateObject("Scripting.Dictionary")
        For Each m In Matches
            List.Add m.SubMatches(1), Nothing
        Next
     End If

Application.OnKey "^{v}", ""

    arr = [a2:b11]
    For i = 1 To UBound(arr)
        If Not IsEmpty(arr(i, 2)) Then
            Cells(Cells(Rows.Count, 7).End(xlUp).Row + 1, 7) = arr(i, 1)
        End If
    Next