Sub web_query()
'otvet% = MsgBox("Внимание!" + Chr(10) + "?????" + Chr(10) + "?????", 48 + 4, "Подключение к базе SQL-server")
'If otvet = 6 Then

Dim WebBrowser1 As Object, o As Object
Dim s As String, URLadr2 As String, URLadr3 As String
Dim nPos As Long, nPos1 As Long, Regn As Integer
    
Set WebBrowser1 = New SHDocVw.InternetExplorer
WebBrowser1.Visible = True

    Regn = ThisWorkbook.Worksheets("CrystalSphere").Cells( 4 ,  3 )
    URLadr2 = "http://cbr.ru/credit/colist.asp?find=" & Regn & "&how=rnum"
    
Call WebBrowser1.Navigate(URLadr2)
'Процедурка ждёт загрузки страницы
Do Until WebBrowser1.ReadyState = READYSTATE_COMPLETE
    Application.Wait ( 1 )
Loop
    'Читаем страницу в HTML, находим адрес ссылки
    s = WebBrowser1.Document.ChildNodes.Item( 1 ).innerHTML
        nPos = InStr( 1 , s, "a href=""javascript:info(", vbTextCompare)
        If nPos <>  0  Then
            nPos1 = InStr(nPos, s, ")"">", vbTextCompare)
            If nPos1 <>  0  Then
                'Переходим по ссылке
                WebBrowser1.Navigate (Mid(s, nPos + Len("a href="""), nPos1 - (nPos + Len("a href=""") -  1 )))
                    Do Until WebBrowser1.ReadyState = READYSTATE_COMPLETE
                        Application.Wait ( 1 )
                    Loop
                'Возвращаем адрес в переменную
                URLadr3 = WebBrowser1.LocationURL
                    With Worksheets("systemlist2").QueryTables.Add(Connection:= _
                        "URL;" + URLadr3, Destination:=Range("$A$1"))
                        .Name = "web_query"
                        .FieldNames = True
                        .RowNumbers = False
                        .FillAdjacentFormulas = False
                        .PreserveFormatting = True
                        .RefreshOnFileOpen = False
                        .BackgroundQuery = True
                        .RefreshStyle = xlInsertDeleteCells
                        .SavePassword = False
                        .SaveData = True
                        .AdjustColumnWidth = False
                        .RefreshPeriod =  0 
                        .WebSelectionType = xlSpecifiedTables
                        .WebFormatting = xlWebFormattingNone
                        .WebTables = "41,44"
                        .WebPreFormattedTextToColumns = True
                        .WebConsecutiveDelimitersAsOne = True
                        .WebSingleBlockTextImport = False
                        .WebDisableDateRecognition = True
                        .WebDisableRedirections = False
                        .Refresh BackgroundQuery:=False
                    End With
            End If
        End If

''''''''''''''''''''''''''Unload WebBrowser1 - не хочет :((((

Set WebBrowser1 = Nothing

End Sub