前回
ken3memo.hatenablog.com
の続きです。
XXXXXさんより、下記の質問が来ました。
> 【VBA IE操作】テーブル単体を取り出す にて勉強中の老人です。
> 上記サンプルはURLを記述して表示して
>WEBページにテーブルの内容を取得しておりますが、
>当方も目的はページを次から次に切り替えて
>その都度にテーブルの内容をEXCLEに蓄積したいと思っ
> てます。(手動で開いたページのテーブル等)
と、
既存IEを手動で操作して、データを抜く、
そんな質問が来ました。
前回、既存IEの取得まで行ったので、
今回は、
テストでテーブルを探し、
選択されたテーブル
をセルに書き出したいと思います。
いつもの 酔っ払い フラフラ解説動画・・・
【1.5倍速】Excel VBA Formから起動済みのIE選択 TABLEを.getElementsByTagName("TABLE")で取得 TEST【三流君】 - YouTube
www.youtube.com
過去に作成した
ken3memo.hatenablog.com
'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 Dim objTABLEs As Object 'TABLEを複数 格納用 'TABLEタグを複数取り出す Set objTABLEs = objIE.document.getElementsByTagName("table") 'まず、書き込み先シートに切り替え、データをクリアする Sheets("DATA").Select 'シートを切り替える Cells.Delete Shift:=xlUp 'シート全体を削除する Range("A1").Select '先頭A1を選択する、 '表をDATAシートに書き出す Dim j As Integer '列の管理 Dim i As Integer '行の管理 Dim n As Integer 'TABLEの管理 Dim yy As Integer 'セットする行 Dim aa As String '一時保管用 'Webの表をシートへ転記(代入する) yy = 1 'セットする位置を初期化 For n = 0 To objTABLEs.Length - 1 'TABLEの数ループ For i = 0 To objTABLEs(n).Rows.Length - 1 '行の数 ループ For j = 0 To objTABLEs(n).Rows(i).Cells.Length - 1 '列のループ 'objTABLEs(テーブル).Rows(行).Cells(列).テキスト値 aa = objTABLEs(n).Rows(i).Cells(j).innerText Sheets("DATA").Cells(yy, j + 1) = aa Next j yy = yy + 1 'セット位置 行を増やす Next i Next n
↑を参考に
'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、
Dim objTABLEs As Object 'TABLEを複数 格納用
'TABLEタグを複数取り出す
Set objTABLEs = objIE.document.getElementsByTagName("table")
で、
テーブル全体を取り出し、
コンボボックスに左上の見出しを書き込みます。
テーブルの左上は、
ken3memo.hatenablog.com
より
Wscript.ECHO objTABLE(n).Rows(0).Cells(0).InnerTEXT
みたいに、
Rows(0)
Cells(0)
でわかるので、
Private Sub btnテーブル探す_Click() 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 Dim objTABLEs As Object 'TABLEを複数 格納用 Dim n As Integer Dim strWORK As String Me.cbTABLELIST.Clear 'TABLE選択用のコンボボックスをクリア、初期化 'TABLEタグを複数取り出す Set objTABLEs = IE.document.getElementsByTagName("table") If objTABLEs.Length = 0 Then 'テーブルが見つからなかったら Me.txtINFO.Text = "TABLEが見つかりません" Exit Sub '関数を抜ける End If 'テーブルが見つかったら、 Me.txtINFO.Text = "TABLEが" & objTABLEs.Length & "個 見つかりました" & vbCrLf For n = 0 To objTABLEs.Length - 1 'TABLEの数ループ '左上の見出しをコンボボックスへ strWORK = "TABLE(" & n & "):" & objTABLEs(n).Rows(0).Cells(0).innerText Me.cbTABLELIST.AddItem Left(strWORK, 80) 'コンボボックスへ追加 Me.txtINFO.Text = Me.txtINFO.Text & strWORK & vbCrLf '情報エリアにも書く Next n End Sub
↑で、コンボボックスを作成して、
次に、テーブルのコンボボックスを選択後に
Excelの書き出しを行うボタンを押してもらいます。
Private Sub btnExcel出力_Click() '未選択のチェック If Me.cbTABLELIST.ListIndex = -1 Then Me.Caption = "未選択 TABLEを選択してください" 'Formタイトルバーに未選択を表示 Exit Sub '関数を途中で抜ける End If '選択されていたら、作業シートに書き込む Dim 最終行 As Integer '急に漢字の変数使うなよ・・・ Sheets("作業").Select 'データセット先に切り替える 最終行 = Cells(Rows.Count, 1).End(xlUp).Row + 1 '最終行+1からセットする Cells(最終行, 1).Select 'カーソルを移動させる DoEvents 'テーブルを探す 'タグの取出しが、.getElementsByTagName("TABLE")で 可能なので、 Dim objTABLEs As Object 'TABLEを複数 格納用 'TABLEタグを複数取り出す Set objTABLEs = IE.document.getElementsByTagName("table") '表をDATAシートに書き出す Dim x As Integer '列の管理 Dim y As Integer '行の管理 Dim n As Integer 'TABLEの管理 'Webの表をシートへ転記(代入する) n = Me.cbTABLELIST.ListIndex 'コンボボックスの選択位置を代入 For y = 0 To objTABLEs(n).Rows.Length - 1 '行の数 ループ For x = 0 To objTABLEs(n).Rows(y).Cells.Length - 1 '列のループ 'objTABLEs(テーブル).Rows(行).Cells(列).テキスト値 Cells(最終行 + y, 1 + x) = objTABLEs(n).Rows(y).Cells(x).innerText Next x Next y '書き込み終了メッセージ MsgBox "シートに書き込みました、確認してください" End Sub
↑まぁ、これだと、結合セルの出力とかうまくいっていない。
あと、
テストで使ってみて、操作性が悪いですね。
いちいち、再取得のボタンを押さないとダメな点は、
改善が必要かなぁ。
Excelブックは
test/Book20170808.zip
に保存しておきます。
これをたたき台として、アレンジして使ってみてください。
何か処理の参考となれば、幸いです。 三流プログラマー Ken3