エクセルIE操作、クラスが二つあり、片方をコピー

質問

お世話になります。
エクセルマクロでのIE操作について質問です。

環境
エクセル2007
visual basic 6.5
参照設定、デフォルトと下記二つを追加
'Microsoft Internet Controls
'Microsoft HTML object Library

エクセルでB列に入力してある単語を、http://www.langtolang.com/から、指定の言語で検索し、
検索結果をシートに貼り付けるものを作ろうとしているのですが、貼り付けに困っています。

作業手順
１、B6から下へ検索したい単語を入力する
２、C2に元の言語、D２に調べたり言語を入力（入力規則で指定しました）
ここからがマクロの手順です
３、IEを開き、指定のページへ移動
４、getelementsbytagnameで、言語の選択と、インプットボックスに単語入力
５、submit
６、検索結果が"no translation found"以外の場合、新しいシートを挿入し、シート名を検索単語に変更し、そこに検索結果をテーブルで貼り付け
７、テーブルに貼り付けたれた検索結果を、検索単語が羅列してあるシートの、検索単語の横に貼り付ける。訳が複数見つかった場合、横並びして張り付ける
これを繰り返す。

このようなものを作りたいのですが、テーブルが複数あり、また同じクラス名のテーブルも複数あるため、どうやって、検索結果だけを選択すれば良いのか困っています。

今のコードは以下です。
よろしくお願いします。

Sub open_ie()

'enable the following reference
'Microsoft Internet Controls
'Microsoft HTML object Library

'VBA version
'VBA version 6.5.10.53

Dim home As Worksheet
Set home = Sheets("Search page")
home.Activate

'open IE

Dim objIE As Object 'create variable
Set objIE = CreateObject("InternetExplorer.Application") 'create object
objIE.Visible = True 'make ie visible

objIE.Navigate "http://www.langtolang.com/" 'navigate Ie to dictionary

'wait while IE is busy
Do While objIE.Busy = True
DoEvents
Loop

'static-------------------------

'Create object variable for source and target language on IE
Dim objSourceLanguage As Object
Dim objTargetLanguage As Object

'choose language by variable.
Dim SourceLanguage As String
Dim TargetLanguage As String
SourceLanguage = Worksheets("Search page").Cells(3, 2).Value
TargetLanguage = Worksheets("Search page").Cells(5, 2).Value

'cell setting--------------------------

Dim i As Integer
i = 6

Dim word As String

'looping procedure stard from here-----------------------------

word = Cells(i, 2).Value

Do While objIE.Busy = True
DoEvents
Loop

objIE.document.forms("frmSozluk").getElementsByTagName("selectFrom") = SourceLanguage 'set source language
objIE.document.forms("frmSozluk").getElementsByTagName("selectTo") = TargetLanguage 'set target language
Do While objIE.Busy = True
DoEvents
Loop
objIE.document.forms("frmSozluk").Item("txtLang").Value = word 'set word in cells(i,2)
objIE.document.forms("frmSozluk").submit

Do While objIE.Busy = True
DoEvents
Loop

'copy output----------------------------------------

Dim table As HTMLTable
Dim sheet As Worksheet

For Each table In objIE.document.all
If table.className = "blue" Then

Sheets.Add after:=Sheets("Search page")
ActiveSheet.Name = word
Set sheet = ActiveSheet

End If
Next

home.Activate

End Sub

回答No.1

DOUGLAS_ · ベストアンサー

＞C2に元の言語、D２に調べたり言語
でしたら、
＞SourceLanguage = Worksheets("Search page").Cells(3, 2).Value
＞TargetLanguage = Worksheets("Search page").Cells(5, 2).Value
は、それぞれ、Cells(2, 3)、Cells(2, 4)、です。

　コード の方が正しいと見なして、「B3に元の言語、B5に調べたい言語」として回答いたします。

＞クラスが二つあり、片方をコピー
＞テーブルが複数あり、また同じクラス名のテーブルも複数ある
とのことで、html ソース を見てみましたが、特に目的の <table> に「id」や「name」が付いている訳でもありませんので、このような場合は、html ソース を丸ごと読み取り、その中から、目的のものを切り出していくか、あるいは、WEB クエリ が使えるのなら、そちらをお使いになるのが簡単ではないでしょうか？

　ということで、
１）html ソース を丸ごと読み取り、その中から、目的のものを切り出していく例
２）WEB クエリ を使った例
の２つを、ご参考に供します。
　私の環境で試したところ、キーワード が６個の場合で、(１) は９秒、(２) は５秒掛かりました。

　なお、
＞参照設定、デフォルトと下記二つを追加
＞'Microsoft Internet Controls
＞'Microsoft HTML object Library
　上記２件は必要ありません。参照設定を外してください。

　また、
＞６、検索結果が"no translation found"以外の場合
は考慮しておりません。

'----------------------------------

Sub use_html_source()
'Microsoft Forms 2.0 Object Libraryを参照設定
　　Dim home As Worksheet
　　Dim objIE As Object
　　Dim i As Integer
　　Dim word As String
　　Dim mytable As String
　　Dim CB As New DataObject

　　Set home = Sheets("Search page")
　　home.Activate
　　Set objIE = CreateObject("InternetExplorer.Application")

　　Application.ScreenUpdating = False
　　With objIE
　　　　.Navigate "http://www.langtolang.com/"
　　　　While .Busy Or .readyState <> 4: DoEvents: Wend
　　　　.document.forms("frmSozluk").Item("selectFrom").Value = home.Cells(3, 2).Value
　　　　.document.forms("frmSozluk").Item("selectTo").Value = home.Cells(5, 2).Value
　　　　For i = 6 To home.Range("B6").End(xlDown).Row
　　　　　　word = Cells(i, 2).Value
　　　　　　.document.forms("frmSozluk").Item("txtLang").Value = word
　　　　　　.document.forms("frmSozluk").submit
　　　　　　While .Busy Or .readyState <> 4: DoEvents: Wend
　　　　　　mytable = .document.body.innerHTML
　　　　　　mytable = Mid(mytable, InStr(mytable, "class=""title"""))
　　　　　　mytable = Mid(mytable, InStr(mytable, "class=""blue"""))
　　　　　　mytable = "<table><tbody><tr" & Left(mytable, InStr(mytable, "</table>")) & "/table>"
　　　　　　With CB
　　　　　　　　.SetText mytable
　　　　　　　　.PutInClipboard
　　　　　　End With
　　　　　　Sheets.Add after:=Sheets(Sheets.Count)
　　　　　　ActiveSheet.Name = word
　　　　　　Range("A1:B1").Value = Array(home.Cells(3, 2).Value, home.Cells(5, 2).Value)
　　　　　　Range("A2").Select
　　　　　　ActiveSheet.Paste
　　　　　　Range(Range("B2"), Range("B" & Rows.Count).End(xlUp)).Copy
　　　　　　home.Select
　　　　　　Range("C" & i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　　　　False, Transpose:=True
　　　　　　Application.CutCopyMode = False
　　　　Next i
　　End With
　　home.Activate
　　Set objIE = Nothing
　　Application.ScreenUpdating = True
End Sub

'----------------------------------

Sub use_web_query()
　　Dim home As Worksheet
　　Dim i As Integer
　　Dim word As String

　　Set home = Sheets("Search page")
　　home.Activate

　　Application.ScreenUpdating = False
　　For i = 6 To home.Range("B6").End(xlDown).Row
　　　　word = Cells(i, 2).Value
　　　　Sheets.Add after:=Sheets(Sheets.Count)
　　　　With ActiveSheet.QueryTables.Add(Connection:= _
　　　　　"URL;http://www.langtolang.com/?selectFrom=" & home.Cells(3, 2).Value & _
　　　　　　"&selectTo=" & home.Cells(5, 2).Value & "&txtLang=" & word _
　　　　　　, Destination:=Range("A1"))
　　　　　　.WebFormatting = xlWebFormattingNone
　　　　　　.WebTables = "6"
　　　　　　.Refresh BackgroundQuery:=False
　　　　End With
　　　　ActiveSheet.Name = word
　　　　Range(Range("B2"), Range("B" & Rows.Count).End(xlUp)).Copy
　　　　home.Select
　　　　Range("C" & i).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
　　　　　False, Transpose:=True
　　　　Application.CutCopyMode = False
　　Next i
　　home.Activate
　　Application.ScreenUpdating = True
End Sub