三流君 ken3のmemo置き場

メモ書きレベルでまとまっていませんがヨロシク

挨拶・自己紹介:
失敗続きのAB型の変わり者 :三流プログラマー Ken3です
フリーのエンジニア・個人事業主です・・と書くと聞こえはイイが(それとなくカッコよく聞こえるが)、 現在は小さな案件の受注請負 と 短期派遣 で 日々つつましく?ほそぼそと暮らしてます。
よく検索されるキーワード: [質問回答XXXXさんへ] [CreateObject] [VBA] [JRA競馬オッズ]


XXXXXさんへ 形の違うweb上の表・テーブル から指定された 項目・列を取得したい

下記の質問をいただく

VBA IEでHP等から表をエクセルに抜き出したい場合ですが
以前に競馬の表の取り込み例として

'TABLEタグを抜き 複数のテーブルをセット
Set objTABLEs = objIE.document.getElementsByTagName("TABLE")
'↑で代入したオブジェクトからテーブルデータを取り出す。

Set objTABLE = Nothing 'オブジェクトを空にする
For i = 0 To objTABLEs.Length - 1 'テーブル数分回す
If objTABLEs(i).Rows(0).Cells(0).innerText = "〇〇" Then
'左上が人気を見つける
Set objTABLE = objTABLEs(i) 'i盤目を代入
Exit For
End If
Next i

'↑で見つかったかチェックする
If objTABLE Is Nothing Then
MsgBox "〇〇が見つかりません"
Exit Sub 'エラー表示して抜ける
End If


'表をDATAシートに書き出す

'Webの表をシートへ転記(代入する)
For y = 0 To objTABLE.Rows.Length - 1 '行のループ
SET_X = 3
For x = 0 To objTABLE.Rows(y).Cells.Length - 1 '列数分ループ
' objTABLE.rows(行).cells(列)
Set objCELL = objTABLE.Rows(y).Cells(x)

'結合セル、枠などに対応
If objCELL.rowSpan > 1 Then '縦に複数の時
Cells(SET_Y + 1, SET_X) = objCELL.innerText '下にも同じくセット
'ホントはループがいいけど、一枠に三頭までなので
If objCELL.rowSpan = 3 Then '3頭め 8枠18番など・・
Cells(SET_Y + 2, SET_X) = objCELL.outerHTML
End If
End If

'既にデータありか、縦に結合されているか?
If Len(Trim("" & Cells(SET_Y, SET_X))) > 0 Then
SET_X = SET_X + 1 '縦結合を飛ばすために横に移動
End If

Cells(SET_Y, SET_X) = objCELL.outerHTML 'データセット

'横に結合されているか判断じゃなかった、横にカラム分移動
SET_X = SET_X + objCELL.colSpan '横に移動 通常は1 結合なし
Cells(SET_Y, 1) = strJYOBOX(j)
Cells(SET_Y, 2) = strRACE



Next
SET_Y = SET_Y + 1

Next
SET_Y = SET_Y + 1 '空白を一行追加
Next

っと参考にさせて頂いておりましたが
これは、常に表の左端、最上段で〇〇というキーワードで
表の全て内容(列)を抜き出しエクセルに抽出していましたが

今回、小生が取り込みたいのは
固定の表でなく抜き出したい項目の列が変動します
それに対応できる抽出で
抜き出したい表が、青色列(固定)A列 B列(ゼッケン、名前)の次に必ず
黄色列(その時により列が変動)前回1~前回5を
続けて抜き出したいです
B列と前回1の間が一定でなく変動した場合でも対応ができますでしょか?

HPの表のパターンとして例で3つ挙げました
欲しいデータは、青色列 A列 B列(ゼッケン、名前)と黄色列の前回1~前回5だけです
※添付のエクセルをご確認ください Sheet1です
可能でしょうか?

また、上記内容が不可能な場合
列が変動する 黄色列の前回1~前回5でけでも抜き出し可能でしょうか?
※添付のエクセルをご確認ください Sheet2です

JRA競馬のオッズ取得だと、
表の左上 .Rows(0).Cells(0).innerText = "〇〇"で判断しているが、
形の違う表から(テストで現在3パターン)
ゼッケン,名前,前回1,前回2,前回3,前回4,前回5
の列を探して取得したい、指定した列を取得したい。

そんな感じかな。
SQL文なら

Select ゼッケン,名前,前回1,前回2,前回3,前回4,前回5
From Web上の表1

Select ゼッケン,名前,前回1,前回2,前回3,前回4,前回5
From Web上の表2

Select ゼッケン,名前,前回1,前回2,前回3,前回4,前回5
From Web上の表3

ってパターンなんだろうけど

さてと、どうするかなぁ・・・・・


下記、いつものヘンテコ解説動画です。
【VBA IE操作】形の違うweb上の表 Tableから指定された項目・列を取得したい【三流君】 - YouTube
www.youtube.com

マクロの入ったxlsmファイルを
http://ie.vba-ken3.jp/test/IE20190109.zip
に保存しました。合わせてみてください。


結果の列とWeb表の列をマッチングさせ、シートにデータを転記するようにします。

1.Excel側、結果の列を用意する

結果の列を用意します。

    '2019/01/09 目的の列を管理する変数ほか
    Dim n列位置 As Integer
    Const 抜き出す列 = "ゼッケン,名前,前回1,前回2,前回3,前回4,前回5"
    Dim str列BOX  '↑からSplitでカンマで分割して、目的の列を配列にする
    str列BOX = Split(抜き出す列, ",")  '配列データを作成

↑まぁ、
Const 抜き出す列 = "ゼッケン,名前,前回1,前回2,前回3,前回4,前回5"
みたいな感じで、設定します。
カンマ区切りを用意したので、Splitで分解、

2.見出しを書き込む

    'ループで列名データを表示させる
    For x = 0 To UBound(str列BOX)   'UBound使用インデックス最大値までループ
        Cells(SET_Y, SET_X + x) = str列BOX(x)
    Next x
    SET_Y = SET_Y + 1  '一行セット位置を下に

3.Webページから表を見つける
前回までだと、左上だけ探してましたが、
今回は列があるか?ループで探してみます。

    'TABLEタグを抜き 複数のテーブルをセット
    Set objTABLEs = objIE.Document.getElementsByTagName("TABLE")
    '↑で代入したオブジェクトからテーブルデータを取り出す。
    
    Set objTABLE = Nothing  'オブジェクトを空にする
    For i = 0 To objTABLEs.Length - 1  'テーブル数分回す
        'web上の表、一行目に目的の列が存在するかチェックする
        For x = 0 To objTABLEs(i).Rows(0).Cells.Length - 1  'web上の表、列数分ループ
            ' objTABLE.rows(行).cells(列)
            Set objCELL = objTABLEs(i).Rows(0).Cells(x)

            For n列位置 = 0 To UBound(str列BOX)  '指定された列名があるかループでチェック?
                If objCELL.innerText = str列BOX(n列位置) Then '列が一つでも見つかったら
                    Set objTABLE = objTABLEs(i)  'i番目のテーブルを代入
                    Exit For
                End If
            Next n列位置
            If Not (objTABLE Is Nothing) Then Exit For  'テーブルが見つかっていたら抜ける
        Next x
        If Not (objTABLE Is Nothing) Then Exit For  'テーブルが見つかっていたら抜ける
    Next i


4.表をみつけたら、シートに書き込みます。
今回は、単純にシートに書き込めないので、
1つ1つ列を比較しながら、せっとしていきます。

    'Webの表をシートへ転記(代入する)
    For y = 1 To objTABLE.Rows.Length - 1  '行のループ ※y=1で二行目からループ
        For x = 0 To objTABLE.Rows(y).Cells.Length - 1  '列数分ループ
            ' objTABLE.rows(行).cells(列)
            Set objCELL = objTABLE.Rows(y).Cells(x) 'これがwebの列
            
            'セットする位置を探して、データをセットする
            'web上の列名と目的の列名を比べ、同じならデータをセットする
            For n列位置 = 0 To UBound(str列BOX)  '指定された列名があるかループでチェック?
                If objTABLE.Rows(0).Cells(x).innerText = str列BOX(n列位置) Then '列が見つかったら
                    Cells(SET_Y, SET_X + n列位置) = objCELL.innerText 'データセット
                    Exit For
                End If
            Next n列位置
        Next
        SET_Y = SET_Y + 1
    Next
    SET_Y = SET_Y + 1  '空白を一行追加

少し、トリッキーですが、こんな感じかな?


テスト
6. セットする列を変えてみる
7.基準のSET_YとSET_Xを変えてテストしてみる
8.連続ページのテスト サンプル1~3を連続でテストしてみる

テスト用html

http://ie.vba-ken3.jp/test/20190109test/sample1.html
http://ie.vba-ken3.jp/test/20190109test/sample2.html
http://ie.vba-ken3.jp/test/20190109test/sample3.html



マクロの入ったxlsmファイルを
http://ie.vba-ken3.jp/test/IE20190109.zip
に保存しました。合わせてみてください。

Ken3 ホームページ 目次

分類:HPを大きく分けると4つの柱(分類)です。
・[Excel/Access VBA]の解説
・[ASP(Active Server Pages)]の解説。
・[元コンビニ店長時代の話]が弟に巻き込まれ、失敗した脱サラ、畑違い?の仕事で失敗。
・[プログラマーの愚痴]では、あまり見せたくない三流プログラマーの内面かな。
三流君を踏み台にする
主に上記4つの分類でHP作成やメルマガの発行を行ってます。
※更新頻度が落ちていて情報の鮮度が悪いです。

三流解説動画の再生リスト
https://www.youtube.com/user/ken3video/playlists

本当に三流なんです(笑):たまにスゴイですねなんて言われることもありますが、
真実は→ [三流君の真実は...] ←を初めに見てくださるとわかると思います。
(からくりは、成功例↑しか載せてなくて ヒドイ失敗例はお蔵入り迷宮入りが多かったりします)