人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

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

これを手でやるには量がありすぎるので、自動化したいと思っています。VBScript,WSHなどなんでも結構ですので、どうやったらこれを実現できるのかお教えください。


●質問者: popattack
●カテゴリ:コンピュータ インターネット
✍キーワード:A1 Excel URL VBScript Wikipedia
○ 状態 :終了
└ 回答数 : 3/3件

▽最新の回答へ

1 ● りくっち
●27ポイント

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

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

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

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


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

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


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


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

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

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

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

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


日本の企業一覧 - Wikipedia

以上ご参考まで。


2 ● degucho
●27ポイント

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

(ヒットしない考慮はしていません)

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

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


3 ● robbie21
●26ポイント

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

AutoSetLinks:

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


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








関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ