Excel2007を使用しています。例えばA列に上場企業名がずらーーっと並んでいるとします。それをWikipediaの企業リンクを自動でExcelのA列に書かれている企業名とリンクしたいと思っています。例えば、A1にトヨタ自動車と書かれているとします。Wikipedia内で検索をかけて、ヒットしたらそのURLをExcelのA1に書かれているトヨタ自動車＝URLのリンクとしたいです。A1のトヨタ自動車をクリックするとWikipedia内のトヨタ自動車が立ち上がってくるようにしたいと思っています。そして今度はA2に行って同じ事をやるようにしたいです。

A列の企業名がどのように表記されているかによって処理内容が少し変わってくると思いますが、

とりあえず企業形態名(株式会社や有限会社など)が除かれたデータが格納されているとして、

(Wikipediaでの見出しがそのようにルール化されているため)

関数のみでできる簡単な方法をご紹介しておきます。

• A列をコピーし、B列に挿入貼り付けします。(別の列でも、別のシートでも構いません。その場合は数式の列名を変更してください)
• A1のデータを消去して、代わりに↓の数式を入力します。

=HYPERLINK("http://ja.wikipedia.org/wiki/"&B1,B1)

以下必要な行までフィルコピーしてください。

これでWikipediaに同名で記述があるものならばA列のセルにハイパーリンクがはられ、飛ぶことができるようになります。

ただ、A列の企業名が間違っていたり、企業形態名がついていたりする場合は、

Wikipediaでの検索自体がワンステップではできないと思いますし、

(例えばトヨタ自動車の場合「トヨタ」なら転送されたりしますが、「トヨタ自動車株式会社」では転送されません)

また、↑の方法は一旦リンクを飛んでみないとエラーがわかりません。

この点も自動化したいという場合はもう少し仕様を明らかにされた方が、お望みの処理により近い回答が得られるのではないかと思います。

日本の企業一覧 - Wikipedia

以上ご参考まで。

簡易版ですが検索リンク追加するマクロを書いてみました。

（ヒットしない考慮はしていません）

改造のベースにはなると思います

Sub Macro1()

    Dim r As Range
    Dim s As String
    Dim i As Long
    
    i = 0
    
    Do
        i = i + 1
        
        Set r = Cells.Item(i, 1)
        s = r.Text
        
        If (s = "") Then
            Exit Do
        End If
        
        ActiveSheet.Hyperlinks.Add r, "http://ja.wikipedia.org/w/index.php?search=" + s
        
    Loop

End Sub

http://officetanaka.net/excel/vba/tips/tips42.htm

2種類のマクロを作りました。

AutoSetLinks:

Googleで wikipedia内を検索して最初にヒットしたリンクを設定するマクロです。

• Set Target = Range("Sheet1!A1:A7") の行で実行範囲を指定しているので必要に応じて変更してください。

ManulaSetLink:

マニュアル操作でリンク設定します。

ActiveCellの値についてGoogleで検索結果が表示されるので、

正しいページを表示後、OKするとリンクが設定されます。

Dim IE

Sub AutoSetLinks()
    InitIE
    Dim Target As Range
    Set Target = Range("Sheet1!A1:A7")
    Dim c As Range
    For Each c In Target.Cells
        Dim WikipediaLink
        WikipediaLink = WikiSearch(c.Value, IE)
        
        c.Worksheet.Hyperlinks.Add c, WikipediaLink

    Next
    CloseIE
End Sub

Sub ManualSetLink()
    Dim url
    InitIE
    url = WikiSearch(ActiveCell.Value, IE)
    MsgBox ("今開いているページでリンク設定します。")
    url = IE.locationurl
    CloseIE
    ActiveCell.Worksheet.Hyperlinks.Add ActiveCell, url
End Sub

Private Function WikiSearch(Word As String, Browser) As String
    
    Dim q As String
    q = "site:http://ja.wikipedia.org/ " & Word
    
    url = "http://www.google.co.jp/search?hl=ja&q=" & UrlEncode(q)
    Do Until Browser.Busy = False
       Application.Wait Now + #12:00:01 AM#
    Loop
    
    Browser.navigate (url)
    
    Do Until Browser.Busy = False
       Application.Wait Now + #12:00:01 AM#
    Loop
    Dim i As Long
    For i = 0 To IE.Document.Links.Length - 1
        Dim Element
        Set Element = Browser.Document.Links(i)
        Dim Title As String
        Title = Element.innerText
        ' Wikipediaのページはタイトルが "-Wikipadia"で終わるので最初に見つかったのを返す
        If Title Like "*- Wikipedia" Then
            Dim Result As String
            Result = Element.href
            
            WikiSearch = Result
            Exit Function
        End If
        
    Next
End Function



Private Sub InitIE()
    Set IE = CreateObject("InternetExplorer.Application")
    IE.Visible = True
    IE.navigate ("http://www.google.co.jp")
    Do Until IE.Busy = False
       Application.Wait Now + #12:00:01 AM#
    Loop
End Sub

Private Sub CloseIE()
    On Error Resume Next
    IE.Quit
    Set IE = Nothing
End Sub

'URLエンコード関数
'
' Originalは
' http://winscript.s41.xrea.com/wiki/index.php?%5B%5B%A5%C6%A5%AF%...
'
Private Function UrlEncode(Source)
     On Error Resume Next
     Dim i
     sTmp = ""
     For i = 1 To Len(Source)
         sChr = Mid(Source, i, 1)
         iAsc = Asc(sChr)
         If iAsc = &H20 Then '空白
             sChr = "+"
         ElseIf (iAsc >= &H40 And iAsc <= &H5A) Or _
         (iAsc >= &H61 And iAsc <= &H7A) Or _
         (iAsc >= &H30 And iAsc <= &H39) Or _
         iAsc = &H2A Or iAsc = &H2D Or _
         iAsc = &H2E Or iAsc = &H5F Then '未変換
         Else
             sHex = Hex(iAsc)
             lHexLen = Len(sHex)
             If lHexLen = 4 Then '2バイト
                 sChr = "%" & Left(sHex, 2) & "%" & Right(sHex, 2)
             ElseIf lHexLen = 2 Then '1バイト
                 sChr = "%" & sHex
             Else '1バイト（Hexで1桁）
                 sChr = "%" & "0" & sHex
             End If
         End If
         sTmp = sTmp & sChr
     Next
     UrlEncode = sTmp
 End Function