痔になりやすい生活習慣とは?

VBAでHTMLのtitleタグの中身を抽出してA1に
入れるにはどうすればよいのでしょうか?

例:<title>Yahoo! JAPAN</title>のYahoo! JAPANをA1に入れる

使用OS:Windows XP
使用ソフト:Microsoft Excel 2003

ご存知の方がおられましたらご回答をよろしくお願いします。

このQ&Aに関連する最新のQ&A

A 回答 (1件)

下記のコードでWin2000&Excel2002では、正常にTitleが取得できました。



'=============================================================
Sub main()
  Dim IE
  Set IE = CreateObject("InternetExplorer.Application")
  With IE
   .Visible = True
   .navigate "http://www.yahoo.co.jp/"
   Do While .Busy = True Or .readyState <> 4
     Loop
   Range("a1").Value = .document.Title
   .Quit
   End With
  Set IE = Nothing
End Sub
    • good
    • 0
この回答へのお礼

早速やってみたところMicrosoft Excel 2003でも正常にTitleが取得できました。
ご回答いただきどうもありがとうございました。

お礼日時:2008/01/28 23:15

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

QVBAを使ってHTMLソースから特定の文字列を抽出したいと思っています

VBAを使ってHTMLソースから特定の文字列を抽出したいと思っています。
正規表現を利用してタグに挟まれた文字を抽出したいのですがうまくいきません。
タグごと抽出する方法でも構わないので教えてください。

例えば
<a href="www.yahoo.com△">○○○</a>   ・・・<1>
※△は(www.yahoo.com)+(半角数字1文字)
※○○○は1文字以上の全角文字

このようなパターンの文字列(<1>を丸ごと)を抜き出すには
どのような正規表現を書けばよいでしょうか?
単に<a href ではじまって </a>  で終わる文字列であれば
<a href.*</a>
で良いと思うのですが、もう少し範囲を絞れば目的の文字列だけを抽出できるので
ぜひ実現させたいと思っています。宜しくお願いします。

Aベストアンサー

 正規表現による抽出にこだわらないでしたら、
>例えば
の答えは、[Links プロパティ] により、 下記のような方法で
>タグごと抽出する
こともできますし、
>もう少し範囲を絞れば目的の文字列だけを抽出
することもできます。

Sub test()
 Dim objIE As Object
 Dim i As Long
 Set objIE = CreateObject("InternetExplorer.Application")
 With objIE
  .navigate "http://www.yahoo.com/"
  While .Busy Or .ReadyState <> 4: DoEvents: Wend
  With .Document
   For i = 0 To .Links.Length - 1
    Cells(i + 1, 1) = .Links(i).outerHTML
    Cells(i + 1, 2) = .Links(i).outerText
   Next
  End With
 End With
 objIE.Quit
 Set objIE = Nothing
End Sub

 正規表現による抽出にこだわらないでしたら、
>例えば
の答えは、[Links プロパティ] により、 下記のような方法で
>タグごと抽出する
こともできますし、
>もう少し範囲を絞れば目的の文字列だけを抽出
することもできます。

Sub test()
 Dim objIE As Object
 Dim i As Long
 Set objIE = CreateObject("InternetExplorer.Application")
 With objIE
  .navigate "http://www.yahoo.com/"
  While .Busy Or .ReadyState <> 4: DoEvents: Wend
  With .Document
   For i = 0 To .Links.Lengt...続きを読む

QエクセルでURLからタイトルのみを抽出する方法

URLからタイトルを抽出するマクロについて教えて下さい。
忍者ブログの記事タイトルをURLから抽出しようとしたのですが
文字化けしてしまい全く分かりません。
他のサイトやブログだと普通に抽出出来るのですが・・・
文字コード?か何かだと思うのですが、原因が分かりません。
ちなみに以下のマクロは、ネット上で検索して見つけたものを
そのままコピーして使用しています。

-------------------------------
Public Sub ReadTitle()
Dim url As Range
Dim Http, buf As String

Set Http = CreateObject("MSXML2.XMLHTTP")
Set url = Range("A3")
Do While (url.Value <> "")
Http.Open "GET", url.Value, False
Http.Send
buf = StrConv(Http.ResponseBody, vbUnicode)
'msgbox buf
url.Offset(0, 1).Value = getTitle(buf)
Set url = url.Offset(1, 0)
Loop
Set Http = Nothing
End Sub

Private Function getTitle(buf As String) As String
Dim pos1 As Long, pos2 As Long

pos1 = InStr(1, buf, "<title>")
If pos1 = 0 Then
pos1 = InStr(1, buf, "<TITLE>")
If pos1 = 0 Then
getTitle = ""
Exit Function
Else
pos2 = InStr(pos1 + 7, buf, "</TITLE>")
End If
Else
pos2 = InStr(pos1 + 7, buf, "</title>")
End If
getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7)
End Function
------------------------------

宜しくお願い致します。

URLからタイトルを抽出するマクロについて教えて下さい。
忍者ブログの記事タイトルをURLから抽出しようとしたのですが
文字化けしてしまい全く分かりません。
他のサイトやブログだと普通に抽出出来るのですが・・・
文字コード?か何かだと思うのですが、原因が分かりません。
ちなみに以下のマクロは、ネット上で検索して見つけたものを
そのままコピーして使用しています。

-------------------------------
Public Sub ReadTitle()
Dim url As Range
Dim Http, b...続きを読む

Aベストアンサー

utf-8みたいなので
>buf = StrConv(Http.ResponseBody, vbUnicode)

With CreateObject("ADODB.Stream")
.Open
.Type = 2 'adTypeText
.Charset = "unicode"
.Writetext Http.ResponseBody
.Position = 0
.Charset = "utf-8"
buf = .ReadText()
.Close
End With
にしてみては?

QExcel VBAでリンク切れをチェックしたい。

Excel VBAでリンク切れをチェックしたい。
図のように、リンク一覧からリンクを調べ、問題なければ「○」を表示し、リンク切れの場合は「×」を表示したいんですが、どんなプログラムを組めばよいですか?
よろしくお願いします。

Aベストアンサー

誰もレスを付けないと思いましたので、こちらでも作りましたのでアップしておきます。
#1の方とは、少し意味が違う部分があるかと思います。

以前、ここの掲示板で出したことがあると思うのですが、もう見つかりません。

一応、今回は、自分用で作ってみました。プロバイダからクレームが付きそうな気がしましたが、実行してしまいました。常識の範囲でお使いください。あまり速くはありませんが、ハングはしませんでした。

リンク先のチェックは、838件を一気にチェックしてしまいましたが、これほどはやらないほうが良いかもしれません。100件やって休むとかしたほうが良いような気がします。

ユーザー定義関数の戻り値は、いくつかあります。ステータス200は、◯ですが、その他は、種類がいろいろありますので、×にせずに数値や文字にしました。基本的に、ステータスコードの200は、全部返しました。

数字については、ステータス・コード表をごらんになってください。
http://www.asahi-net.or.jp/~ax2s-kmtn/ref/status.html

例:
404 サイトがなくなっています。
403 アクセス権限がないということですから、ログインしなければ分からないかもしれません。
他にも、いくつか種類が出てきます。
n.a と出るのは、サーバーが受け付けないものだと思います。

アンチウィルスソフトで、禁止区域に入った時は、メッセージが出てきました。しかし、そのままで続いていきます。
このマクロ使用中でも、スクロールは可能です。

場所は標準モジュールです。

''//--
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private objHTTP As Object
Sub Main_URLChecking()
  Dim c As Range
  Dim i As Long
  ''Microsoft WinHTTP Service, version 5.1 '参照設定する場合
  ''Set objHTTP=New winHttp.WinHttpRequest '
  For Each c In Range("B2", Cells(Rows.Count, 2).End(xlUp))
    If LCase(c.Value) Like "http://*" Then
      c.Offset(, 1).Value = CheckURL(c.Value)
      Sleep 200  'Wait を掛ける
      DoEvents   'ESCで離脱できるようにする。
    End If
  Next
   Set objHTTP = Nothing
End Sub
Function CheckURL(ByVal strURL As String) As Variant
  Dim num As Variant
  On Error GoTo ErrHandler
  If objHTTP Is Nothing Then
     Set objHTTP = CreateObject("WinHttp.WinHttpRequest.5.1")
  End If
  objHTTP.Open "GET", strURL, False
  objHTTP.Send
  If objHTTP.Status = 200 Then
    CheckURL = "◯"
  Else
    CheckURL = objHTTP.Status
  End If
  Exit Function
ErrHandler:
  If Err() <> 0 Then
    CheckURL = "n.a"
  End If
End Function

''//--


なお、今度は、これを、ハイパーリンクのリストに反映しないといけないのかな?

誰もレスを付けないと思いましたので、こちらでも作りましたのでアップしておきます。
#1の方とは、少し意味が違う部分があるかと思います。

以前、ここの掲示板で出したことがあると思うのですが、もう見つかりません。

一応、今回は、自分用で作ってみました。プロバイダからクレームが付きそうな気がしましたが、実行してしまいました。常識の範囲でお使いください。あまり速くはありませんが、ハングはしませんでした。

リンク先のチェックは、838件を一気にチェックしてしまいましたが、これほどはやらな...続きを読む

QEXCELファイルのカレントフォルダを取得するには?

EXCELファイルのカレントフォルダを取得するには?

C:\経理\予算.xls

D:\2005年度\予算.xls

EXCEL97ファイルがあります。

VBAで
  カレントフォルダ名
(C:\経理\,D:\2005年度\)
を取得する事は可能でしょうか?

CURDIRでは上手い方法が見つかりませんでした。

Aベストアンサー

こんばんは。
Excel97 でも、同じですね。以下で試してみてください。

Sub test()
'このブックのパス
a = ThisWorkbook.Path
'アクティブブックのパス
b = ActiveWorkbook.Path
'Excelで設定されたデフォルトパス
c = Application.DefaultFilePath
'カレントディレクトリ
d = CurDir
MsgBox "このブックのパス   : " & a & Chr(13) & _
   "アクティブブックのパス: " & b & Chr(13) & _
   "デフォルトパス    : " & c & Chr(13) & _
   "カレントディレクトリ : " & d & Chr(13)
End Sub

QEXCEL VBAマクロ作成で、他のEXCELからデータを取り込みたい

メインプログラム(EXCEL VBA)より、
他のフォルダーにあるEXCELの項目の内容を取り込みたいです。
たとえば他のフォルダーのEXCELのRange("A2:A3").ValueをメインプログラムのRange("C2:C3").Valueにセットしたい時です。

・コマンドボタン押したら、どこのEXCELから取り込むかのポップアップ(?)は、表示はできてます。
・作業者が選んだパスとブックもMsgBoxで表示できてるので、もらう相手の場所も取得できてます。

・となると次はOPEN,INPUTですか?
テキストデータの取り込みですと、Inputでそのバッファを定義してるのですが、なんか違うような。。。

よろしくお願いします!

Aベストアンサー

私がやる方法です。

Dim writeSheet As Worksheet ' 自分自身の書き出し先シート
Set writeSheet = ThisWorkbook.Worksheets(1) ' Sheet1 を参照

Dim readBook As Workbook ' 相手ブック
Set readBook = Workbooks.Open(filename) ' 相手ブックを開いて参照
Dim readSheet As WorkSheet ' 相手シート
Set readSheet = readBook.Worksheets("sheetName") ' 相手シートを参照
' または Set readSheet = readBook.Worksheets(sheetIndex)

' 例えば
writeSheet.Cells(1, 1).Value = readSheet.Cells(2, 2).Value ' 相手シートの B2 の値を自分自身の A1 に書き込む

readBook.Close False ' 相手ブックを閉じる
Set readSheet = Nothing
Set readBook = Nothing

私がやる方法です。

Dim writeSheet As Worksheet ' 自分自身の書き出し先シート
Set writeSheet = ThisWorkbook.Worksheets(1) ' Sheet1 を参照

Dim readBook As Workbook ' 相手ブック
Set readBook = Workbooks.Open(filename) ' 相手ブックを開いて参照
Dim readSheet As WorkSheet ' 相手シート
Set readSheet = readBook.Worksheets("sheetName") ' 相手シートを参照
' または Set readSheet = readBook.Worksheets(sheetIndex)

' 例えば
writeSheet.Cells(1, 1).Value = readSheet.Ce...続きを読む

QVBA オブジェクトが空かどうか判定する

皆様のお知恵を拝借させてください。

エクセルVBAでオブジェクトを入れる変数を定義し、その変数にオブジェクト
が入っているかどうか検査したいのですがどうしたらいいでしょうか。

例えば---
Dim a As Workbook
If a <> nothing then ←この部分が分からない。このままだとエラー。
処理
End if
---------
環境
エクセル2003
WinXPsp1

Aベストアンサー

もし、aが空だったら
If a Is Nothing Then 

もし、aが空じゃなかったら
If Not a Is Nothing Then

QEXCEL VBAでたくさんのURLの一覧からHTTPレスポンスコードを取得したい。

VBA初心者です。
EXCEL VBAでプログラミングの練習をしています。

シート名:一覧
URL記入セル:A1~A100
結果を記入するセル:B1~B100
があり、URL記入セルに入力されているURLにアクセスし
レスポンスコードを(404とか200とか)B列に書き出す
というのを実行できるコードの書き方を教えてください。
(1週間取り組んでいますがまだできません・・・)
サンプルコードを直接改定頂けると最高です。

宜しくお願いします。

Aベストアンサー

こんな感じでしょうかね。たぶん。。。

Sub Sample()

  Dim i As Long
  Dim bottom As Long
  
  bottom = Range("A65536").End(xlUp).Row
  
  For i = 1 To bottom
    
    Range("B" & i) = GetWebStatus(Range("A" & i))
  
  Next i
  
End Sub

Function GetWebStatus(URL As String) As String

  Dim WinHttp As Object

  Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")

On Error GoTo INVALID

  WinHttp.Open "GET", URL, False
  WinHttp.send

  GetWebStatus = WinHttp.Status
  
  Set WinHttp = Nothing
  
  Exit Function
  
INVALID:
  GetWebStatus = "Invalid URL"
  
  Set WinHttp = Nothing
  
  
End Function

こんな感じでしょうかね。たぶん。。。

Sub Sample()

  Dim i As Long
  Dim bottom As Long
  
  bottom = Range("A65536").End(xlUp).Row
  
  For i = 1 To bottom
    
    Range("B" & i) = GetWebStatus(Range("A" & i))
  
  Next i
  
End Sub

Function GetWebStatus(URL As String) As String

  Dim WinHttp As Object

  Set WinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")

On Error GoTo INVALID

  WinHttp.Open "GET", URL, ...続きを読む

QWebページ中の javascript をVBAから実行するには

VBAで objIE を使用して Webページ中の javascript を実行したいのですが、
onclick="~~" の記述がないケースがあり困っております。
例えば以下のような記述です。

<a href="javascript:;" pnb="~~" scdaction="~~" bulkaction="~~" id="~~">~~</a>

onclick の記述がない上記のようなケースでは、javascript の呼び出しはどのようにすればよいのでしょうか?
不可能でしょうか?

Aベストアンサー

ここを読んでみればよいのですが、だらだらと文章が長いですね。^^;
http://www.ken3.org/vba/backno/vba170.html
この内容のまとめは、この後でします。もし、ダメだったら、こちらも読んでください。

>onclick="~~" の記述がないケースがあり困っております。

最初に、ストレートな回答ではありませんが、私の場合、いくつかの方法を試しています。

>a href="javascript:;" pnb="~~" scdaction="~~" bulkaction="~~" id="~~">~~</a>
この場合は、id がありますから、確実のオブジェクトとして取得できますから、まず最初に、ダメ元で、
id名.Click を一度試してみます。もしくは、この行の上部のコードのオブジェクトのClass名のオブジェクトのひとつから、ヒットさせようとします。

そこでダメなら、ということで、ken3の内容に入るのですが、この著者の結論(正解)は、

ご質問に沿って書くと
For i =0 To objIE.Document.links.Length -1
If objIE.Document.links(i).href ="javascript:;" Then '文字の比較は、大文字・小文字がある
   objIE.Document.Links(i).Click
End if
Next i

ということになっています。私は、このコードは少し古臭く感じます。

ここで、ken3 の所では、Testサイトを用意してくれているので、試してみましたが、ダイレクトでサイトがとれている限りは、やはり、

Testサイト:http://www.ken3.org/vba/test170f.html

 objIE.Navigate "javascript:xxxxx;"

が利くことが分かりました。ただし、実際は、ここで時間待ちをしなくてはならないでしょう。
解説は、フレームからですので、うまく行かなかったようです。

ここを読んでみればよいのですが、だらだらと文章が長いですね。^^;
http://www.ken3.org/vba/backno/vba170.html
この内容のまとめは、この後でします。もし、ダメだったら、こちらも読んでください。

>onclick="~~" の記述がないケースがあり困っております。

最初に、ストレートな回答ではありませんが、私の場合、いくつかの方法を試しています。

>a href="javascript:;" pnb="~~" scdaction="~~" bulkaction="~~" id="~~">~~</a>
この場合は、id がありますから、確実のオブジェクトとして取得できますか...続きを読む

QVBAからhttpを呼びソースを取得

ブラウザでURLを指定すると、htmlがサーバーから返され表示されます。
それをVBAからURLを指定し、htmlのソースを文字列で受け取りたいと思います。

普通にshellで渡すとブラウザが起動されてしまうし・・・。

方法があれば教えてください。

Aベストアンサー

HTMLテキストを取るには
Sub test01()
Set obj = CreateObject("InternetExplorer.Application.1") 'IEを新規オブジェクトとして宣言
obj.Visible = True
targetURL = "http://okweb.jp/kotaeru.php3?qid=1044759"

obj.Navigate (targetURL) '指定アドレスに飛ばす
'時間待ち(objが動作中であれば)
Do While obj.busy
Loop

'表示
obj.Visible = True
For n = 0 To obj.Document.All.Length - 1
If UCase(Trim(obj.Document.All(n).tagname)) = "HTML" Then
s = obj.Document.All(n).outerhtml 'HTMLのテキスト
Cells(n + 1, 1) = s 'エクセルONLY用
End If
Next
End Sub
2,3のWEBに載ってたものの寄せ集めですが。
なかなか載って無いものですね。
sが文字列です。エクセルなどでは、長さ制約あり。
WSHやBASP21やWEBBROWSERなど使う方法があるようですが、不勉強で全体を見渡せていないので取りあえず。

HTMLテキストを取るには
Sub test01()
Set obj = CreateObject("InternetExplorer.Application.1") 'IEを新規オブジェクトとして宣言
obj.Visible = True
targetURL = "http://okweb.jp/kotaeru.php3?qid=1044759"

obj.Navigate (targetURL) '指定アドレスに飛ばす
'時間待ち(objが動作中であれば)
Do While obj.busy
Loop

'表示
obj.Visible = True
For n = 0 To obj.Document.All.Length - 1
If UCase(Trim(obj.Document.All(n).tagname)) = "HTML" Then
s = obj.Docum...続きを読む

QVBAからIEを操作する時のウィンドウの選択の仕方がわかりません

VBAで、webページを操作するマクロを組んでいます。
具体的な手順としては、セルの商品番号をweb上の検索ボックスに入力して、別ウィンドウで開いた情報を「すべて選択」「コピー」してexcellの別シートに「貼り付け」までを行うものなのですが、
別ウィンドウで開いたページに対して、Sendkeysを行うにはどうやったらいいのでしょうか。
仮に、入力ページをA、結果ページをBとしたとき、Aに対しての入力とBページの表示までは出来ているのですが、Bページに対しての操作が出来ません。

ちなみに、事情があってwebクエリはあえて使っていません。
どなたか、いい解決方法・プロシージャをご存知でしたらよろしくお願いします。

Aベストアンサー

こんにちは。KenKen_SP です。

検索フォーム経由ではなく、検索結果のページをコードで直接開けないですか?
例えば、教えてGooなら

http://oshiete1.goo.ne.jp/kotaeru.php3?q=


URL の後ろに ? マークがあります。この記号以下は CGI に渡すパラメータです。
q= の後ろに質問番号が入りますので、予め質問番号が分かっている場合は、
この URL に質問番号を連結してやれば、直接開くことができます。

仮に、質問番号が A1 セルに入っているなら

IE.Navigate "http://oshiete1.goo.ne.jp/kotaeru.php3?q=" & Range("A1").Value

みたいなコードで検索結果ページを開くことができると思います。同様に、商品番号
を渡すパラメータがあるはずですから、探して見て下さい。CGI にパラメータを渡す
方法が Get でも Post の場合でも検索フォームの HTML ソースを見れば分かります。

取り合えず、一度検索フォームの HTML ソースを見てみましょう。

これが可能なら、コードで IE オブジェクトを作り、直接検索結果のページを開くこ
とができますので、IE のウインドウハンドルやウインドウタイトルは簡単に取得
できます。

簡単な例です。A1 セルの値を Google で検索し、結果を A5 セルに貼り付けます。


Option Explicit

Private Declare Function SetForegroundWindow Lib "user32.dll" ( _
  ByVal hWnd As Long _
) As Long
  
Sub Sample()

  Dim IE   As Object
  Dim strURL As String
  Dim lngRet As Long
  
  Const READYSTATE_COMPLETE = &H4
  
  strURL = "http://www.google.com/search?hl=ja&lr=lang_ja&ie=Shift_JIS&q="
  strURL = strURL & Range("A1").Value
   
  Set IE = CreateObject("InternetExplorer.application")
  IE.Visible = True
  IE.navigate strURL
  Do
    DoEvents
  Loop Until Not IE.Busy And IE.readyState = READYSTATE_COMPLETE
  
  ' IE のウインドウをアクティブにする
  lngRet = SetForegroundWindow(IE.hWnd)
  If lngRet <> 0 Then
    ' アクティブにできたらキー送信して結果をコピー
    SendKeys "^a", True
    SendKeys "^c", True
    ' 貼り付け
    Range("A5").Select
    ActiveSheet.Paste
  End If
  Set IE = Nothing

End Sub

どうしても検索フォームを経由し、新しい IE を開く必要がある場合は、
参考 URL 先の記事が参考になると思います。

参考 URL: http://www.ken3.org/cgi-bin/group/vba_ie.asp

ちなみに、SendKeys を使わない方法としては、IE.Document.body.innerHTML
で HTML ソースは取得し、クリップボードに転送してからペースト、、

というのでも良いかもしれません。

では。

こんにちは。KenKen_SP です。

検索フォーム経由ではなく、検索結果のページをコードで直接開けないですか?
例えば、教えてGooなら

http://oshiete1.goo.ne.jp/kotaeru.php3?q=


URL の後ろに ? マークがあります。この記号以下は CGI に渡すパラメータです。
q= の後ろに質問番号が入りますので、予め質問番号が分かっている場合は、
この URL に質問番号を連結してやれば、直接開くことができます。

仮に、質問番号が A1 セルに入っているなら

IE.Navigate "http://oshiete1.goo.ne.jp/kot...続きを読む


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング