こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

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

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

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

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

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

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

投稿日時 - 2011-09-29 00:38:25

QNo.7040730

困ってます

質問者が選んだベストアンサー

>C2に元の言語、D2に調べたり言語
でしたら、
>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 クエリ が使えるのなら、そちらをお使いになるのが簡単ではないでしょうか?

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

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

 また、
>6、検索結果が"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

投稿日時 - 2011-09-29 12:51:31

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(1)

あなたにオススメの質問