AccessVBAのWebスクレイピングにおけるWeb上のテーブルデータをAccessテーブルに書き込みたい

Question

前提・実現したいこと

AccessVBAのWebスクレイピングにおけるWeb上のテーブルデータをAccessテーブルに書き込みたいと思っています。
ExcelVBAにおいては、以下のコードで実現しておりますが、AccessでのRecordsetへの組み込み方法が分かりません。

ソースコード

'Web上のテーブルデータをExcelシートに書き出す関数
Public Sub WriteTableData(ByVal table As HTMLTable, ByVal cell As Range)
            
    Dim i As Long: i = 0
    Dim tr As HTMLTableRow
    For Each tr In table.getElementsByTagName("tr")
            
        Dim j As Long: j = 0
        Dim th As HTMLTableCell
        For Each th In tr.getElementsByTagName("th")
            cell.Offset(i, j).Value = th.innerText
            j = j + 1
        Next th
        
        Dim td As HTMLTableCell
        For Each td In tr.getElementsByTagName("td")
            cell.Offset(i, j).Value = td.innerText
            j = j + 1
        Next td      
        i = i + 1
    Next tr
End Sub

'Webスクレイピング処理
Private Sub table_build()

    Dim objIE As InternetExplorer
    Dim hUrl As String
    Dim objShell As Object
    Dim objExec As Object
    
    hUrl = "https://" '該当ページのURL ※伏せています
    
    Set objIE = CreateObject("Internetexplorer.Application")

    objIE.Visible = True
    Call ieView(objIE, hUrl)
    Call Wait(objIE)
    
    Dim htmlDoc As HTMLDocument
    Set htmlDoc = objIE.Document
    
　　'テーブル書き出し関数呼び出し
    WriteTableData htmlDoc.getElementsByClassName("Table01")(0), Worksheets("書き出し").Range("A1")

    Call Wait(objIE)
    
    'IEを閉じる
    Set objShell = CreateObject("WScript.Shell")
    Set objExec = objShell.Exec("taskkill.exe /F /IM iexplore.exe")
    
End Sub

試したこと

WriteTableData関数と呼び出しコードからRangeの引数を省いて、
cell.Offset(i, j).ValueをAccess用に改変すれば実現可能かと思い、

    Dim RsData As Recordset
    Dim mydb As Database
    Set mydb = CurrentDb
    Set RsData = mydb.OpenRecordset("Accessテーブル")
--------省略--------
        For Each td In tr.getElementsByTagName("td")
                RsData.Fields(i) = td.innerText
            j = j + 1
        Next td

という具合にしてみたのですが、
フィールドを指定していないせいで、思うように追加してくれませんでした。
そもそもinnerTextで、フィールド別に分けることなどできるのでしょうか？

同じ事例がウェブ上から探せず困り果てております。
参考となるページがあればご紹介いただけると幸いです。

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

補足情報（FW/ツールのバージョンなど）

Windows10 x64
Office2013 x86

Answer 1

Excelのセルは何でも代入できますが、Accessの場合はフィールドにはデータ型があり、データ型が異なるデータは基本的には代入できません。
Accessのテーブルのフィールド数・フィールドのデータ型は、HTMLのテーブルのデータと合うように設計されているか確認してください。

次にVBAでAccessのテーブルのデータ操作をするには、DAOを使用する場合と、ADOを使用する場合があります。それをどちらにするか決めてください。AccessのVBAならば、DAOの方が扱いやすいと思います。
（追記: 質問のコードではDAOを使っているようですのでそれでOKですね。）

次に、DAO(またはADO)でデータを追加するコードを調べてください。WEB検索すればサンプルコードはいくらでも見つかります。例えば、下記ではDAOとADOのコード例があります。

DAO・ADOでのデータの追加～マイクロソフトアクセス(Access)活用法(メルマガ）

上記のヒントを参考に、ExcelのコードをAccess用に書き換えてください。不明な点がでたら、どこまでできて、どこが不明なのか質問に追記してください。

---

Web上の目的のTableデータはすべてString型なので、
Access側ではIDのオートナンバーを省いて
Stringフィールドのみにしております。

これの仕様でのコード例
IDフィールドは無しとする

'Web上のテーブルデータをAccessテーブルに書き出す関数
Public Sub WriteTableData(ByVal table As HTMLTable, ByVal tblName As String)
    Dim mydb As Database
    Set mydb = CurrentDb
    Dim RsData As Recordset
    Set RsData = mydb.OpenRecordset(tblName)
                
    Dim tr As HTMLTableRow
    For Each tr In table.getElementsByTagName("tr")
        If tr.getElementsByTagName("td").length > 0 Then
            Dim i As Long: i = 0 'テーブルの1列目から代入
            Dim td As HTMLTableCell
            RsData.AddNew
            On Error Resume Next
            For Each td In tr.getElementsByTagName("td")
                RsData.Fields(i) = td.innerText
                i = i + 1
            Next td
            If Err.Number <> 0 Then
                'エラー内容をイミディエイトウィンドウへ出力
                Debug.Print Err.Number & ": " & Err.Description
                Err.Clear
            End If
            On Error GoTo 0 'エラー処理を解除
            RsData.Update
        End If
    Next tr
    
    RsData.Close
End Sub

直書きなのでミスがあるかも。ロジックを参考にしてください。

Comments

[GoogleWindows]

hatena19様

早急なご回答、感謝いたします。
Web上の目的のTableデータはすべてString型なので、
Access側ではIDのオートナンバーを省いて
Stringフィールドのみにしております。

私が不明なのは、web上のテーブルデータをフィールド別に小分けにする方法です（単一データの取得や書き込みは普段DAOではなくSQL文のinsertを使用しておりますので特に問題ありません）。
innerTextだと、一行ずつ読みますが、テーブルデータ一行分がすべて代入されており、フィールド別に分けることができません。
Webスクレイピングする段階で、どのようにフィールド別に小分けにするのか知りたいと思っております。
どうかよろしくお願いいたします。

[hatena19]

> innerTextだと、一行ずつ読みますが、テーブルデータ一行分がすべて代入されており、フィールド別に分けることができません。

質問のコードでは、
For Each td In tr.getElementsByTagName("td")
となってますので、フィールド(セル)毎にデータが取れているはずですが、1行分になりますか。
"tr"なら1行、"td"はセルになるはずです。

現状のコードを省略せずに正確に提示してもらえますか。

[GoogleWindows]

ご回答ありがとうございます。

Public Sub WriteTableData(ByVal table As HTMLTable)

Dim RsData As Recordset
Dim mydb As Database
Set mydb = CurrentDb
Set RsData = mydb.OpenRecordset("Accessテーブル")

RsData.AddNew

Dim i As Long: i = 0
Dim tr As HTMLTableRow
For Each tr In table.getElementsByTagName("tr")

Dim j As Long: j = 0
Dim th As HTMLTableCell
For Each th In tr.getElementsByTagName("th")
RsData.Fields(i) = th.innerText
j = j + 1
Next th

Dim td As HTMLTableCell
For Each td In tr.getElementsByTagName("td")
RsData.Fields(i) = td.innerText
j = j + 1
Next td
i = i + 1
Next tr

End Sub

このようになっております。

それと、先ほどブレークポイントで止めて一行ずつ実行してみましたら
ひと値ずつtd.innerTextに格納されておりました。
失礼いたしました。
最終的に、「テーブルに書き込めません」というエラーが出て終わっています。
また、forのループ回数ですが、
どうやらAccessで設定したフィールドの回数分ループしているようでした。まだまだwebテーブルの行数はたくさんあるはずなのに、
Accessで指定したフィールド数（列数）分しかforが回っていないようです。
RsData.Fields(i)に問題があるのでしょうか？

[hatena19]

WEBのテーブルの1行毎に AddNew して代入後に UpDate する必要があります。
コード例を回答に追加しておきますのでしばらくお待ちください。

[GoogleWindows]

サンプルコードまでご提供くださり、大変感謝いたします。

If tr.getElementsByTagName("td").Count > 0 Then
この行でエラーが出たのと、thタグのForが見当たらないのもあって
そのまま使用せず、一部を引用させていただき、とりあえず取得できるか試してみました。
そうすると、おかげさまでテーブルに見事書き出されました。
ただ、階段のように一行ずつ下にズレていたため、Forでフィールド分ループさせようとしましたが、「RsData.Fields(i)でコレクションがない」という旨のエラーが出たので取り除きました。
また、webのテーブルデータは100行ほどしかないのに600行以上、空欄も含めて取得してしまいます。

Public Sub WriteTableData(ByVal table As HTMLTable, ByVal tblName As String)

Dim RsData As Recordset
Dim mydb As Database
Set mydb = CurrentDb
Set RsData = mydb.OpenRecordset(tblName)
Dim p As Long

RsData.AddNew

Dim tr As HTMLTableRow
For Each tr In table.getElementsByTagName("tr")

Dim j As Long: j = 0
Dim th As HTMLTableCell
For Each th In tr.getElementsByTagName("th")
j = j + 1
Next th

Dim td As HTMLTableCell
Dim i As Long: i = 0

For Each td In tr.getElementsByTagName("td")
RsData.AddNew
RsData.Fields(i) = td.innerText
i = i + 1
RsData.Update
Next td
j = j + 1
Next tr

End Sub

RsData.Updateをforの外に出すと、何も取得できませんでしたのでこういう形になりましたが、やはりhatena19様がご提示くださったコードを修正していく形の方が良いようです。

そうなると、
If tr.getElementsByTagName("td").Count > 0 Then
この部分で、なぜ「オブジェクトは、このプロパティまたはメゾットをサポートしていません」とエラーが出るのかよく分からないです。
tr.getElementsByTagName("td").Countの部分をあらかじめLong型などに代入しても同じエラーが出ます。
せっかくサンプルコードまで示してくださったのに、ふがいない質問者で申し訳ございません。

[GoogleWindows]

あれこれやっているうちにできました。
下記のように修正してみました。

'Web上のテーブルデータをAccessテーブルに書き出す関数
Public Sub WriteTableData(ByVal table As HTMLTable, ByVal tblName As String)
Dim mydb As Database
Set mydb = CurrentDb
Dim RsData As Recordset
Set RsData = mydb.OpenRecordset(tblName)

Dim tr As HTMLTableRow
For Each tr In table.getElementsByTagName("tr")
If tr.getElementsByTagName("td").Item > 0 Then
Dim i As Long: i = 0 'オートナンバーフィールド無しの為0から
Dim td As HTMLTableCell
RsData.AddNew
For Each td In tr.getElementsByTagName("td")
On Error Resume Next
RsData.Fields(i) = td.innerText
i = i + 1
Next td
RsData.Update
End If
Next tr

RsData.Close
End Sub

countがエラーを吐いていたようで、Itemにへんこうしたのと、
コレクションがないエラーは、不本意ですがOn Error Resume Nextを入れてスルーするようにしました。

このコードに何か問題がなければよいのですがいかがでしょうか？

[hatena19]

> countがエラーを吐いていたようで、
あっすみません。length でした。

On Error Resume Next はなるべく狭い範囲にとどめたほうがいいでしょう。他でエラーが出た場合のデバッグが困難になりますので。

回答のコードを修正しますので、参考にしてください。

[GoogleWindows]

ふがいない質問ばかり投げてしまって申し訳ございませんでした。
色々と丁寧に教えてくださり、大変感謝しております。

今回のことで多くのことが学べそうです。
まだまだ先ほどいただいたコードに関してはすべてを理解しておりませんので、これからじっくり見させていただこうと思います。
本当にありがとうございました。また機会がありましたら宜しくお願いいたします。

[GoogleWindows]

わざわざコードを修正してくださってありがとうございます。
試しに走らせたら問題なく動きました。
こちらのコードの方が洗練されていて、より参考になりそうです。
何から何まで感謝の限りです。

[hatena19]

エラーログをイミディエイトウィンドウに出力するようにしてますので、
実行した後、イミディエイトウィンドウを確認してエラーがあるか確認してください。
エラーがある場合は、そのエラーログから原因を特定して、
可能なら対策してエラーが出ないようにするといいでしょう。

[GoogleWindows]

SQL文のエラーチェックを行う際、Debug.Printでイミディエイトウィンドウに出力されたSQL文をクエリに起こして確認したりしておりました。
hatena19様が書かれておられるような方法は今回初めて拝見いたしましたのでとても参考になります。
重ね重ねありがとうございます。