あなたの人生に効く作品がみつかる手書きのカード♪>>

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
------------------------------

宜しくお願い致します。

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

A 回答 (3件)

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
にしてみては?
    • good
    • 0
この回答へのお礼

一発解決出来ました。
ありがとうございました!

お礼日時:2010/01/24 18:41

参照設定をして、以下のコードを実行すると


指定した。URLで、IEが起動して、
URLのタイトルがエクセルのイミディエイトウィンドに出ます。

Dim ie As New InternetExplorer
Dim dc As HTMLDocument


ie.Navigate "http://oshiete1.goo.ne.jp/qa5617517.html"

ie.Visible = True

Do While ((ie.Busy = True) Or (ie.ReadyState <> READYSTATE_COMPLETE))

DoEvents

Loop


Set dc = ie.Document

Debug.Print dc.Title

Set ie = Nothing

******
実行結果

エクセルでURLからタイトルのみを抽出する方法 - 教えて!goo

********
文字コードは、検証していませんが。
ieで表示して、たぶん文字コードが
文字化けしていなければ
大丈夫なような気もしますが。
未検証です。
    • good
    • 0
この回答へのお礼

皆様のおかげで解決することが出来ました。
お時間を割いて頂きありがとうございました。

お礼日時:2010/01/24 18:42

こんにちは。



>忍者ブログの記事タイトルをURLから抽出しようとしたのですが

こんな感じでいかがですか?
>buf = StrConv(Http.ResponseBody, vbUnicode)
ここがへんかもしれません。

以下は、必要でしたら、サブルーチン・プロシージャに分けてください。
'-------------------------------------------
Public Sub ReadTitleR()
Dim stRng As Range
Dim buf As String, ar As Variant
Dim i As Long
With CreateObject("MSXML2.XMLHTTP")
  Set stRng = Range("A3")
  For i = 1 To Cells(Rows.Count, stRng.Column).End(xlUp).Row
    If StrConv(stRng.Cells(i, 1).Value, vbLowerCase) Like "http://??*" Then
      .Open "GET", stRng.Cells(i, 1).Value, False
      On Error Resume Next
      .Send
      On Error GoTo 0
      buf = .ResponseText
      If .Status >= 200 And .Status < 300 And buf <> "" Then
        ar = Split(buf, "title>")
        stRng.Cells(i, 2).Value = Mid(ar(1), 1, Len(ar(1)) - 2)
      End If
    End If
  Next i
End With
End Sub
'-------------------------------------------
    • good
    • 0
この回答へのお礼

皆様のおかげで解決することが出来ました。
お時間を割いて頂きありがとうございました。

お礼日時:2010/01/24 18:42

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

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

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

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

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

Qlink先のURLとタイトル一覧の取得方法

例えばlink集のようなページがあり、そこに掲載のlink先のURLと、そのタイトル(titleタグ)を簡単に一覧で取得するツールやブラウザのアドオンなどあれば教えてください。

Aベストアンサー

link集のようなページをコピーしてエクセルに貼り付け、次のユーザー定義関数を使ってみてください。

エクセルのハイパーリンク先のURLを取得するユーザー定義関数

数式で設定しているものを除きます。
ファイルやドキュメント内リンクも除きます。
URLは、最初に設定しているhttpから始まっているものを返します。
A1セルに設定しているハイパーリンクのURLを表示するには、以下の式を使います。

= GetURL(A1)

設定方法は、
1.Alt + F11 で VBE(Visual Basic Editor)を開きます。
2.VBE のメニューから[挿入] -->[標準モジュール] を指定します。
3.コードウィンドウに下記コードをコピーして貼り付けます。
4.右上隅の×でウィンドウを閉じ、シートに戻ります。
5.メニューから[開発]の[マクロのセキュリティ]の、
「マクロの設定」で「警告を表示してすべてのマクロを有効にする」、
 「開発者向けのマクロ設定」で「VBAプロジェクト オブジェクト モデルへのアクセスを信頼する」にチェックを入れてOKをクリックする。

これで、GetURL関数が使用できる状態になります。

Function GetURL(Rng As Range) As String
Dim Adr As String
If Rng.Hyperlinks.Count > 0 Then
With Rng.Hyperlinks(1)
If .Address Like "http*" Then
Adr = .Address
End If
End With
End If
If Adr <> "" Then
GetURL = Adr
Else
GetURL = ""
End If
End Function

link集のようなページをコピーしてエクセルに貼り付け、次のユーザー定義関数を使ってみてください。

エクセルのハイパーリンク先のURLを取得するユーザー定義関数

数式で設定しているものを除きます。
ファイルやドキュメント内リンクも除きます。
URLは、最初に設定しているhttpから始まっているものを返します。
A1セルに設定しているハイパーリンクのURLを表示するには、以下の式を使います。

= GetURL(A1)

設定方法は、
1.Alt + F11 で VBE(Visual Basic Editor)を開きます。
2.VBE のメニューから...続きを読む

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を文字としてほしい(http○○・・)のですが、できますか?
青文字を右クリックしてハイパーリンクの編集からURLは見られるのですが、たくさんのリンクリストからURLだけを抽出するのが大変なので、よい方法がありましたらお願いします。

Aベストアンサー

No3 です。
サブアドレスの存在を忘れていました。
訂正です。

Public Sub GetURL()
  Dim h As Hyperlink
  Dim a As String
  Dim s As String
  For Each h In ActiveSheet.Hyperlinks
    a = h.Address
    s = h.SubAddress
    If s <> "" Then
      a = a & "#" & s
    End If
    h.Range.Offset(0, 1) = a
  Next
End Sub

QVBAでHTMLのtitleタグの中身を抽出してA1に入れたい

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

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

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

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

Aベストアンサー

下記のコードで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

QExcel 文字列の前後に、特定の文字を付加したい

Excelで、ある列に不規則な文字列がならんでいます。
その文字列の前後に、いっせいに好きな文字を付加したいのです。
例えば、「AAA」という文字列の前後に
「BBBACCC」といったように
AAAといった文字列にBBBやCCCと一斉に付加したいです。
AAAはアルファベットや日本語等さまざまなのですが、
どうすればいいでしょうか?
教えてください。

Aベストアンサー

& で繋ぎます。

A1 セルの文字の前後に、ABC と DEF を付けたいなら、
別のセルに下記のような式を入れます。

="ABC" & A1 & "DEF"

QExcel ハイパーリンクのURLを別のセルに表示したい。

Excel ハイパーリンクのURLを別のセルに表示したい。

例えば、A1セルに「あいうえお」と入力され、かつハイパーリンクで、
「http://www.aiueo.com」というURLがリンクされているとします。
この、「http://www.aiueo.com」を B1セルに表示させたいです。

なにか良い関数やフリーソフト等はありませんでしょうか??
(ACCESSの場合は、簡単なクエリーのみ利用できるレベルです。)

よろしくお願いします。

Aベストアンサー

こちらで。
http://oshiete.goo.ne.jp/qa/2356920.html

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件を一気にチェックしてしまいましたが、これほどはやらな...続きを読む

Qエクセルで、条件に一致した行を別のセルに抜き出す方法

エクセルで、指定した条件に一致するセルを含む行をすべて抜き出す方法が知りたいです。

たとえば、

<A列> <B列> <C列>
7/1 りんご 100円
7/2 ぶどう 200円
7/2 すいか 300円
7/3 みかん 100円

このような表があって、100円を含む行をそのままの形で、
別のセル(同じシート内)に抜き出したいのですが。

7/1 りんご 100円
7/3 みかん 100円

抽出するだけならオートフィルターでもできますが、
抽出結果を自動的に、別の場所に、常に表示させておきたいのです。

初歩的な質問だと思いますが、検索しても分からなかったので、よろしくお願いします。

Aベストアンサー

同じ質問が結構よく出てますが、そんなに初歩的でもありません
別シートのA1セルに「100円」と入力し、そのシートの任意のセルに以下の式を貼り付けて下さい。後は、下方向、右方向にコピー。
日付のセル書式は「日付」形式に再設定してください

=IF(COUNTIF(Sheet1!$C:$C,$A$1)>=ROW(A1),INDEX(Sheet1!A:A,LARGE(INDEX((Sheet1!$C$1:$C$500=$A$1)*ROW(Sheet1!$C$1:$C$500),),COUNTIF(Sheet1!$C:$C,$A$1)-ROW(A1)+1)),"")

データ範囲は500行までとしていますが、必要に応じて変更して下さい

QエクセルのIF関数で、文字が入力されていたならば~

エクセルのIF関数で文字が入力されていたならば~、という論理式を組み立てたいと思っています。

=IF(A1="『どんな文字でも』","",+B1-C1)

A1セルに『どんな文字でも』入っていたならば、空白に。
文字が入っていなければB1セルからC1セルを引く、という状態です。

この『どんな文字でも』の部分に何を入れればいいのか教えてください。

またIF関数以外でも同様のことができれば構いません。

宜しくお願いします。

Aベストアンサー

=IF(ISTEXT(A1),"",B1-C1)

でどうでしょうか?

QDoEvents関数って何?

こんにちは。

VBAやプログラミングに詳しい皆様に
教えていただきたい質問があります。

cells(1,1)からcells(5000,1)までの値を消去するときに
処理の進行状況を表示するためにuserform上にプログレスバーを表示したいと思います。

そこで下記のようなコードを入力しました。

userform1.show
for i =1 to 5000
cells(i,1)=""
userform1.progressbar1.value=i/5000*100
next i
unload userform1

しかしこれだとuserformの背景が真っ白になってしまい
ラベルの文字も消えてしまいます。
そこで「EXCEL VBA パーフェクトマスター」という本を見たら

for i =1 to 5000
cells(i,1)=""
userform1.progressbar1.value=i/5000*100
DoEvents
next i
unload userform1
と入力すれば解決することがわかりました。

しかし「DoEvents」についてあまり詳しく書いていなかったのでDoEvents関数をヘルプで見ると、
「発生したイベントがオペレーティング システムによって処理されるように、プログラムで占有していた制御をオペレーティング システムに渡すフロー制御関数です。」

と書いてあるのですが正直、書いてあることがよくわかりません。

どなたかDoEvents関数について、
もう少しわかりやすく教えていただけませんか。
それから、最初に書いたコードで実行すると
ユーザーフォームの背景が真っ白になってしまう原因も
教えていただけませんか?

よろしくお願いいたします。

こんにちは。

VBAやプログラミングに詳しい皆様に
教えていただきたい質問があります。

cells(1,1)からcells(5000,1)までの値を消去するときに
処理の進行状況を表示するためにuserform上にプログレスバーを表示したいと思います。

そこで下記のようなコードを入力しました。

userform1.show
for i =1 to 5000
cells(i,1)=""
userform1.progressbar1.value=i/5000*100
next i
unload userform1

しかしこれだとuserformの背景が真っ白になってしまい
ラベルの文字も消えてしまいます。
そ...続きを読む

Aベストアンサー

簡単に言うと、
OS に制御を渡すってことです。(ヘルプそのまんま)
時間が掛かるループ処理などの場合、ループが終わるまで制御は独占されてしまいます。
ですのでループ中は OS や Excel そのものにも再描画をさせる暇さえ与えません。
途中に DoEvents を入れると制御が OS に渡るので、OS は溜まっていた処理をそこで行うことができます。
結果、フォームの再描画などが行われることになります。

注意点ですが、
Private Sub CommandButton1_Click()
  Dim i As Long

  For i = 1 To 50000
    DoEvents
    Cells(i,1) = ""
  Next i
End Sub

Private Sub CommandButton2_Click()
  MsgBox "hoge"
End Sub

っていうフォームのコードがあった場合、
DoEvents を入れることによって、ループ中にユーザーがCommandButton2 を押すことによって CommandButton2 のクリック イベントも動いちゃいます。
CommandButton1 のクリック イベントではループの前に
CommandButton1.Enabled = False
CommandButton2.Enabled = False
を書いてフォーム上の CommandButton を無効にしておき、ループが終わったら
CommandButton1.Enabled = True
CommandButton2.Enabled = True
と書いて CommandButton を有効に戻してください。

これを工夫すれば、CommandButton2 で CommandButton1 のループを途中キャンセルする処理もすることができます。

Private Canceled As Boolean

Private Sub CommandButton1_Click()

  CommandButton2.Enabled = False

  Dim i As Long
  For i = 1 To 50000
    DoEvents

    If Canceled = True Then
      MsgBox "キャンセルしました"
      Exit Sub
    End If

    Cells(i, 1).Value = ""
  Next i
End Sub

Private CommandButton2_Click()
  Canceled = True
End Sub



コードの行頭にあるスペースは見易さのために全角スペースで作成していますので、これをこのままコピペするとエラーになるかもしれません。
コピペするなら行頭の全角スペースを半角スペースに直してください。

簡単に言うと、
OS に制御を渡すってことです。(ヘルプそのまんま)
時間が掛かるループ処理などの場合、ループが終わるまで制御は独占されてしまいます。
ですのでループ中は OS や Excel そのものにも再描画をさせる暇さえ与えません。
途中に DoEvents を入れると制御が OS に渡るので、OS は溜まっていた処理をそこで行うことができます。
結果、フォームの再描画などが行われることになります。

注意点ですが、
Private Sub CommandButton1_Click()
  Dim i As Long

  For i = 1 To 50000
...続きを読む


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

人気Q&Aランキング