Const google = "https://www.google.com.ua/webhp?sourceid=chrome-instant&ion=1&espv=2&ie=UTF-8#q=Имя"
Sub test()
    arr = Range("A1:A3").Value
    ReDim arrNew(1 To UBound(arr, 1), 1 To 2)
    
    For i = 1 To UBound(arr, 1)
        arrNew(i, 1) = arr(i, 1)
        arrNew(i, 2) = Wikipedia(arr(i, 1))
    Next i
    
    Range("B1").Resize(UBound(arr, 1), 2).Value = arrNew
    MsgBox "done!"
End Sub

Private Function Wikipedia(sName)
On Error GoTo ErrLabel
    ss = GetHTTPResponse(sName)
    ss = Replace(ss, Chr(9), "")
    ss = Replace(ss, Chr(10), "")
    ss = Replace(ss, Chr(13), "")
    ss = Replace(ss, "<", "|")
    ss = Replace(ss, ">", "|")
    m = Split(ss, "ru.wikipedia.org/wiki/")
    n = Split(m(1), "|")
    Exit Function
ErrLabel:
    Wikipedia = ""
End Function

Private Function GetHTTPResponse(ByVal sName)
    On Error Resume Next
    sURL = Replace(google, "Имя", sName)
    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    With oXMLHTTP
        .Open "GET", sURL, False
        .send
        GetHTTPResponse = .responseText
    End With
End Function