VBAの検索について（xls88）

質問

すいません、前回の投稿を途切らせてしまったため、続きを再度投稿させて頂きます。xls88 様

その後、手作業で進めてまいりましたが終わりが見えず、、、
職場の方から「mooter」で試してみればとのアドバイスをもらいました。
前回のプログラムを
myUrl = "?http://www.google.co.jp/"?　→　myUrl = "?http://www.mooter.co.jp/"?
に書き換えましたが、上手くいきませんでした。他にどこを修正すると動作するでしょうか？
何度も申し訳ありませんがよろしくお願いいたします。

回答No.14

xls88

回答番号：No.13 この回答への補足 で示されたコードは不完全です。
書き直してみました。

★1a、★1b、でコード進行を遅延させてみます。
例では2秒に設定しています。
実際のところ良く分かっていないのですが、上手く動くかもしれません。
★2a、で★2bで使っている変数の宣言をしています。
今回のコードでは、サブプロシージャwebReadyStateは必要ありません。

Dim objIE As Object
Dim c As Range
Dim mytime As Variant '★1a
Dim tmp As Object, tmp1 As Object '★2a

Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True
For Each c In Range("A1:A6")
objIE.Navigate c.Value

'表示と読み込みが完了するまで待機する
Do While objIE.Busy = True
DoEvents
Loop
Do While objIE.ReadyState <> 4
DoEvents
Loop
'★1b、更に指定時間の空ループで遅延させてみる
mytime = Now + TimeValue("00:00:02")
Do While Now < mytime
DoEvents
Loop

On Error Resume Next
With objIE.Document
'≪Title≫
c.Offset(, 1).Value = .Title
With .all.Tags("meta")
'≪keywords≫
'name属性
c.Offset(, 2).Value = .Item("keywords").Content
'★2b、http-equiv属性の場合
If .Item("keywords").Content = "" Then
Set tmp1 = objIE.Document.getElementsByTagName("meta")
For Each tmp In tmp1
If tmp.httpequiv = "keyword" Then
c.Offset(, 2).Value = tmp.Content
Exit For
End If
Next
End If
'≪description≫
c.Offset(, 3).Value = .Item("description").Content
End With
End With
On Error GoTo 0
Next

Set objIE = Nothing
Set tmp1 = Nothing

＃余計なお節介ですが
ＶＢＥのヘルプ
http://miyahorinn.fc2web.com/vbabegin/s_02_03.html
デバッグについて
http://members.jcom.home.ne.jp/rex-uchida/vba110.htm

補足

xls88さま

ご返信ありがとうございます（T T）
頂いたコードで確認してみます。
ヘルプもちょっと見てみますね。
少しお時間くださいませ。

回答No.13

xls88

＞回答番号：No.12 この回答への補足
＞no.9でのアドバイス頂いたものは試したのでが、上手くいきませんでした。
回答番号：No.12で提示したように、mytimeを入れてみたが駄目だった、ということですか。
回答番号：No.11 この回答への補足、で提示されたコードではその辺が窺えないので、回答番号：No.12で再掲しました。

上手くいかない、というだけでは何ともし難いです。
エラーはでるのか出ないのか？
エラーがでるなら、エラーコードと内容、エラー発生行はどうなっているのか？
無駄かもしれませんが、現在の状況が分かるように、具体的に伝えるようにしてください。

補足

お返事ありがとうございます。
そして、説明べたですみません、、、

エラーが出てしまうのは、Ａ列にあるhttp://www.mol.co.jp/のところで
「実行時エラー'91' オブジェクト変数またはWithブロック変数が設定されていません。」と表示されます。
デバックをすると→c.Offset(, 2).Value = .Item"keywords").Contentと表示されます。

今使っているコードは下のものが全てになります。No12でアドバイス頂いた物も入れているのでが、、、要領が悪くてすみません。

Sub test()

Dim objIE As Object
Dim c As Range

Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True

For Each c In Range("A1:A6")
objIE.Navigate c.Value

Do While objIE.Busy = True
DoEvents
Loop
Do While objIE.ReadyState <> 4
DoEvents
Loop

On Error Resume Next
With objIE.Document
'≪Title≫
c.Offset(, 1).Value = .Title
With .all.Tags("meta")
'≪keywords≫
'name属性
c.Offset(, 2).Value = .Item("keywords").Content
'http-equiv属性
If .Item("keywords").Content = "" Then
Set tmp1 = objIE.Document.getElementsByTagName("meta")
For Each tmp In tmp1
If tmp.httpequiv = "keyword" Then
c.Offset(, 2).Value = tmp.Content
Exit For
End If
Next
End If
'≪description≫
c.Offset(, 3).Value = .Item("description").Content
End With
End With
On Error GoTo 0

Next

Set objIE = Nothing

End Sub

Sub webReadyState(myWindow)
Dim mytime As Variant
With myWindow
Do While .Busy = True
DoEvents
Loop
Do While .ReadyState <> 4
DoEvents
Loop
End With
mytime = Now + TimeValue("00:00:02")
Do While Now < mytime
DoEvents
Loop
End Sub

回答No.12

xls88

＞回答番号：No.11 この回答への補足
何を設定されたのか何も見えません。
回答番号：No.9で提案した内容は試してみましたか？
試したけども、駄目だったのですか？

Dim mytime As Variant

Do While objIE.Busy = True
DoEvents
Loop
Do While objIE.ReadyState <> 4
DoEvents
Loop
mytime = Now + TimeValue("00:00:02")
Do While Now < mytime
DoEvents
Loop

補足

おはようございます。
すみません(：_；)

no.9でのアドバイス頂いたものは試したのでが、上手くいきませんでした。
私自身ちゃんとわかっていなくてすみません．．．

回答No.11

xls88

＞私の設定が良くないのでしょうか、、、
どういう設定をされているのですか？
見せて頂けないと何とも解りません。
コードを全文提示できないでしょうか。

補足

すみません（：_；）
コード忘れていました。
いかがでしょうか？

Dim objIE As Object
Dim c As Range

Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True

For Each c In Range("A1:A6")
objIE.Navigate c.Value

Do While objIE.Busy = True
DoEvents
Loop
Do While objIE.ReadyState <> 4
DoEvents
Loop

On Error Resume Next
With objIE.Document
'≪Title≫
c.Offset(, 1).Value = .Title
With .all.Tags("meta")
'≪keywords≫
'name属性
c.Offset(, 2).Value = .Item("keywords").Content
'http-equiv属性
If .Item("keywords").Content = "" Then
Set tmp1 = objIE.Document.getElementsByTagName("meta")
For Each tmp In tmp1
If tmp.httpequiv = "keyword" Then
c.Offset(, 2).Value = tmp.Content
Exit For
End If
Next
End If
'≪description≫
c.Offset(, 3).Value = .Item("description").Content
End With
End With
On Error GoTo 0

Next

Set objIE = Nothing

回答No.10

xls88

http-equiv属性の"keyword"を取ってみました。

On Error Resume Next
With objIE.Document
'≪Title≫
c.Offset(, 1).Value = .Title
With .all.Tags("meta")
'≪keywords≫
'name属性
c.Offset(, 2).Value = .Item("keywords").Content
'http-equiv属性
If .Item("keywords").Content = "" Then
Set tmp1 = objIE.Document.getElementsByTagName("meta")
For Each tmp In tmp1
If tmp.httpequiv = "keyword" Then
c.Offset(, 2).Value = tmp.Content
Exit For
End If
Next
End If
'≪description≫
c.Offset(, 3).Value = .Item("description").Content
End With
End With
On Error GoTo 0

補足

たくさんアドバイスありがとうございます(^-^)

でも、すいません。同じところで同じエラーが出て止まってしまいます。私の設定が良くないのでしょうか、、、

何度もすみません(：_；)

回答No.9

xls88

＞回答番号：No.8 この回答への補足
回答番号：No.3の内容を適用してみてください。

回答No.8

xls88

回答番号：No.7のコードは、On Error ステートメントを前後に置いてあります。
エラーが発生しても、エラー行をスルーして次の行が実行されるはずです。

理解できませんが、異なる要因のエラーが発生しているのでは？
エラー内容、発生行はどうなっていますか？

補足

そーなんですね！
勘違いしました(^^;)

エラーは、例えば　http://www.mol.co.jp/　の場合、
titleを取得したところで処理が止まってしまい、
「実行時エラー'91' オブジェクト変数またはWithブロック変数が設定されていません。」と表示されます。
デバックをすると→
c.Offset(, 2).Value = .Item("keywords").Content
となります。

どうでしょうか？

回答No.7

xls88

Dim objIE As Object
Dim c As Range

Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True

For Each c In Range("A1:A3")
objIE.Navigate c.Value

Do While objIE.Busy = True
DoEvents
Loop
Do While objIE.ReadyState <> 4
DoEvents
Loop

On Error Resume Next
With objIE.Document
c.Offset(, 1).Value = .Title
With .all.Tags("meta")
c.Offset(, 2).Value = .Item("keywords").Content
c.Offset(, 3).Value = .Item("description").Content
End With
End With
On Error GoTo 0
Next

Set objIE = Nothing

残念ながら http://www.mol.co.jp/ の"keywords"が取れません。
HTMLソースにName属性が使われていないからだと思います。
<meta http-equiv="keyword" content="＊＊＊＊＊＊＊＊＊＊">

補足

おはようございます。
早速ありがとうございます（＾＾）

Name属性がないとうまく取れないんですね。
これは、descriptionやTitleも同じでしょうか？

何度か動かしてみたのですが、この部分で止まってしまいます。
うまく取れない場合は、スルーして次の行に進むことは可能でしょうか？

よろしくお願いいたしますm(_ _)m

回答No.6

xls88

＞１．descriptionとkeywordsとtitleだけを上手く選べません、、、
セルA1に
http://www.vaio.sony.co.jp/
とURLが記述されているとして、下記で試してください。

Dim objIE As Object
Dim objTD As Object

Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True

'セルデータのURLを起動
objIE.Navigate Range("A1").Value

Do While objIE.Busy = True
DoEvents
Loop
Do While objIE.ReadyState <> 4
DoEvents
Loop

Set objTD = objIE.Document.all.Tags("meta")

'≪タイトル≫
MsgBox objIE.Document.Title
'≪keywords≫
MsgBox objTD.Item("keywords").Content
'≪description≫
MsgBox objTD.Item("description").Content

Set objIE = Nothing
Set objTD = Nothing

上手く動いたなら、抽出データのセル書き込みを工夫してください。

＞２．IEを開いたままで、webアドレスだけ入れ替えたいのですが、、、
＞３．webアドレスをエクセルのＡ列から自動的にとりたいのですが、、
URL起動部分を、ループ処理すればよいかもしれません。

補足

xls88様
ご回答ありがとうございます(^^)

MsgBoxのところを下記のようにしましたら、必要な項目だけ入りました！ありがとうございます！

'Range("b1") = objIE.Document.Title
'Range("c1") = objTD.Item("keywords").Content
'Range("d1") = objTD.Item("description").Content

＞＞３．webアドレスをエクセルのＡ列から自動的にとりたいのですが、、
＞URL起動部分を、ループ処理すればよいかもしれません。

すみません、ここが分かりません（：_；）
URLの起動部分と上記の取得項目の書込場所をループしていくのかと思いますが、、、、
ないアタマを振り絞って考えたのですが、思いつきませんでした。
教えていただけませんでしょうかｍ（_ _）ｍ

※Ａ列は以下のような感じです。
http://www.vaio.sony.co.jp/
http://denko.panasonic.biz/Ebox/powertool/
http://www.mol.co.jp/

どうかよろしくお願いいたします。

回答No.5

xls88

進んでいますか？
まだ閉じられないのは躓いているのですか？
解らなければ遠慮なく捕捉で質問してください。

VBAからのWebブラウザ起動
http://lcl.web5.jp/prog/excel_vba/ietest.html

補足

xls88様
ご連絡遅くなってすみません。
風邪と忙しさと頭の悪さで全然進まず、、、(T T)
気にかけて頂いて、ありがとうございます！

紹介頂いたサイトを参考にしながら（マネしながら）取りあえず作ってみたのですが、、、思うようにいきません。

１．descriptionとkeywordsとtitleだけを上手く選べません、、、
２．IEを開いたままで、webアドレスだけ入れ替えたいのですが、、、
３．webアドレスをエクセルのＡ列から自動的にとりたいのですが、、

どうぞご指南お願いいたしますm(_ _)m

Sub test()

Dim objIE As Object
Set objIE = CreateObject("InternetExplorer.application")
objIE.Visible = True

objIE.Navigate "http://www.vaio.sony.co.jp/"

Do While objIE.Busy = True
DoEvents
Loop
Do While objIE.ReadyState <> 4
DoEvents
Loop

Dim objTD As Object
Set objTD = objIE.Document.all.Tags("meta")

Dim n As Integer
For n = 0 To objTD.Length - 1
Cells("1", n + 1) = n
Cells("2", n + 1) = "'" & Left(objTD(n).OuterHTML, 80)
Next n
Set objTD = Nothing

End Sub