Summary
時給が１０００円前後の事務員さんに必要なVBAでのスクレイピングの知識（テーブル編）
想定読者さん
事務員さん
Greeting
こんにちは。時給１０００円の事務派遣バイトを始めたcallmekoheiです。みなさま、いかがお過ごしでしょうか？
福岡というまぁ、ローカル地方都市なのですが、そこでの時給１０００円の事務員さんに求められる業務改善のお仕事内容は例えば、、、
ブラウザ上の業務システムでの作業にて
手作業で入力・登録など
１項目あたり３０秒で行なっていたのを
５秒に改善する
また手作業で見受けられたミスはないようにする
たとえば１日５００項目として
１項目あたり２５秒の改善なので
１日あたり約３時間ほどの改善で、
１ヶ月２０日として
年間で７２０時間、時給２０００円（従業員）として
１５０マソの効果金額
みたいな感じです。これをだいたい１週間ないし２週間でやれと・・・（地方厳しいぽよ）
その際に必要なテクニックとしてVBAでのスクレイピングなのですが、まったくの知らない状態から１週間の業務で試行錯誤で身につけたので情報共有（シェア）したいと思います。
VBAとは？
エクセルなどMicrosoft Office製品を多用する日本の事務員さんとは相性のいいプログラミング言語（マクロ）です。エクセルに標準で付随してます。使用することは決して楽とは言い切れませんが、習得することで絶大な事務効率の恩恵に授かれます。
RPAとVBAの関係は？（ここは独り言）
WinActorを少しかじった程度なので、なんとも言えないですが、RPAとVBAの関係は代替関係でなく補完関係です。そしてここは私感なのですが、もし稟議をとって導入できるもしくは導入検討をしてるのであれば導入した方がいいと思います。その際に速度などで不満がある場合はVBAで作り込む方がいいというのが実感です。根拠はVBAだけだと事務員さんの負担が大きいからです。一人だけならまだしも複数人の事務員さんでのVBAでの自動化はほぼ無理だと思います。
VBAスクレイピングの基礎
いろいろな方がホームページで書かれてるので、そこを参照してみてください。
使用するライブラリ
下記２点があると便利なのでおすすめです
スクレイピングする際に便利なライブラリ
victorze-vba/Scraping
VBAで使用する定石な関数が収録されているライブラリ
vbaidiot/ariawase
以下、上記２点のライブラリを使用してのコードですが、自作されても構いません
サンプル１
ヤホーのカレンダーを表示する
Private Sub Yahoo_Calendar_Array()
''' ============================
''' ヤホーのカレンダーを表示する
''' ============================
''' ヤホーを立ち上げる
Dim url As String: url = "https://www.yahoo.co.jp/"
Dim doc As Scraping: Set doc = New Scraping
doc.gotoPage url, True
''' テーブルを取得する
Dim selector As String: selector = "#pbcNx > table"
Dim tables As Scraping: Set tables = ReadyTables(doc, selector, 1)
''' テーブルを配列にする
Dim table As Variant: table = ArrTable(tables.index(0).rowTable, True)(1)
''' 各Rowを表示する
Dim v As Variant
For Each v In table
Debug.Print Dump(v)
Next v
doc.Quit
End Sub
結果
Array("日", "月", "火", "水", "木", "金", "土")
Array("26", "27", "28", "29", "30", "31", "1")
Array("2", "3", "4", "5", "6", "7", "8")
Array("9", "10", "11", "12", "13", "14", "15")
Array("16", "17", "18", "19", "20", "21", "22")
Array("23", "24", "25", "26", "27", "28", "29")
Array("30", "1", "2", "3", "4", "5", "6")
テーブルを配列に変換する関数
''' @param table As Object(Of MSHTML.HTMLTable)
''' @return As Variant(Of Array(Of Array (Of Array (Of HTMLTableCell Or String))))
Public Function ArrTable(ByVal table As Object _
, Optional ByVal asInnerText As Boolean = False) As Variant
Dim arr() As Variant: ReDim arr(0 To table.children.Length - 1)
Dim i As Long
For i = 0 To UBound(arr)
arr(i) = ArrTableSection(table.children.Item(i), asInnerText)
Next i
ArrTable = arr
End Function
''' @param tblSct As Object(Of MSHTML.HTMLTableSection)
''' @return As Variant(Of Array(Of Array (Of HTMLTableCell Or String)))
Public Function ArrTableSection(ByVal tblSct As Object _
, Optional ByVal asInnerText As Boolean = False) As Variant
If typeName(tblSct) = "object HTMLTableSectionElement" Then Err.Raise 13
Dim n As Long: n = tblSct.children.Length
Dim arr As Variant: arr = Array(): ReDim arr(0 To n - 1)
Dim i As Long
For i = 0 To n - 1
If typeName(tblSct.children.Item(i)) = "HTMLTableRow" Then
arr(i) = ArrTableSection(tblSct.children.Item(i), asInnerText)
Else '''HTMLTableCell
If asInnerText Then
arr(i) = tblSct.children.Item(i).InnerText
Else
Set arr(i) = tblSct.children.Item(i)
End If
End If
Next i
ArrTableSection = arr
End Function
サンプル２
ヤホーのカレンダーの 6日 がある行を表示する
業務ロジックを関数に分離する
--> Ariawaseの関数ポインタ（WinAPI DispCallFuncを使用）を使用すると便利です！
Private Sub Yahoo_Calendar_Within6()
''' ===========================================
''' ヤホーのカレンダーの 6日 がある行を表示する
''' ===========================================
''' テーブルを配列に変換する
Dim url As String: url = "https://www.yahoo.co.jp/"
Dim doc As Scraping: Set doc = New Scraping
doc.gotoPage url, True
Dim selector As String: selector = "#pbcNx > table"
Dim tables As Scraping: Set tables = ReadyTables(doc, selector, 1)
Dim table As Variant: table = ArrTable(tables.index(0).rowTable)(1)
''' 業務ロジック
''' 6 という数字があるレコードのみテーブルから抽出する
Dim v As Variant
For Each v In ArrRemoveEmpty(ArrMap(init(New Func, vbVariant, AddressOf Within6, vbVariant), table))
Debug.Print Dump(ArrMap(init(New Func, vbString, AddressOf toInnerText, vbObject), v))
Next v
End Sub
Private Function Within6(ByVal row As Variant) As Variant
Dim v As Variant
For Each v In row
If v.InnerText = "6" Then
Within6 = row
GoTo Escape
End If
Next v
Escape:
End Function
結果
Array("2", "3", "4", "5", "6", "7", "8")
Array("30", "1", "2", "3", "4", "5", "6")
サンプル３
みずほ銀行のホームページから最新のロト６の当選番号テーブルを取得する
ホームページをみたまま取得する（JavaScriptで動的に作成されるHTMLを取得する）
Private Sub Sample_Loto6()
''' ========================================
''' ロト６の最新の当選番号テーブルを表示する
''' ========================================
''' テーブルを配列に変換する
Dim url As String: url = "https://www.mizuhobank.co.jp/retail/takarakuji/loto/loto6/index.html"
Dim doc As Scraping: Set doc = New Scraping
doc.gotoPage url, True
Dim selector As String: selector = "table.typeTK"
Dim tables As Scraping: Set tables = ReadyTables(doc, selector, 1, 0, 1)
Dim tableArr As Variant: tableArr = ArrTable(tables.index(0).rowTable, True)
''' データを表示する 0 is header, 1 is body , 2 is footer
''' header
Debug.Print Dump(tableArr(0)(0))
''' body
Dim v As Variant
For Each v In tableArr(1)
Debug.Print Dump(v)
Next v
doc.Quit
End Sub
結果
Array("回別", "第1376回")
Array("抽せん日", "2019年5月2日")
Array("本数字", "02", "05", "22", "31", "32", "43")
Array("ボーナス数字", "(27)", " ")
Array("1等", "該当なし", "該当なし")
Array("2等", "6口", "12,929,700円")
Array("3等", "227口", "369,000円")
Array("4等", "11,845口", "7,400円")
Array("5等", "176,893口", "1,000円")
Array("販売実績額", "1,523,042,600円")
Array("キャリーオーバー", "507,783,386円")
テーブルを取りこぼさずに取る関数
Public Function ReadyTables(ByVal doc As Scraping, ByVal selector As String _
, Optional ByVal ms_waitTime As Long = 1 _
, Optional ByVal row As Long = 0 _
, Optional ByVal col As Long = 0 _
, Optional ByVal tableIndex As Long = 0 _
, Optional ByVal tableCount As Long = 1 _
) As Scraping
Dim i_error As Long
On Error GoTo ErrHandle
Dim tables As Scraping, record As Variant
ReadyTablesImpl tables, record, doc, selector, tableIndex, row
''' Check if a particular element of the array is a empty string.
Do While record(col) = ""
Wait ms_waitTime
DoEvents
ReadyTablesImpl tables, record, doc, selector, tableIndex, row
Loop
Do While tables.count < tableCount
Wait ms_waitTime
DoEvents
ReadyTablesImpl tables, record, doc, selector, tableIndex, row
Loop
On Error GoTo 0
Set ReadyTables = tables
GoTo Ending
ErrHandle:
i_error = i_error + 1
If i_error > 500 Then
MsgBox "Error Raise --- ReadyTables ---"
Stop
ElseIf i_error > 100 Then
ReadyTablesImpl tables, record, doc, selector, tableIndex, row
End If
Resume
Ending:
End Function
Private Function ReadyTablesImpl(ByRef tables As Scraping, ByRef record As Variant, _
ByVal doc As Scraping, ByVal selector As String, ByVal tableIndex As Long, ByVal row As Long)
Set tables = doc.css(selector)
record = ArrTableSection(tables.index(tableIndex).rowTable.children.Item(row), True)
If IsArray(record(0)) Then record = record(0)
End Function
おまけ
業務改善を求められる事務派遣バイトさんは、オチンギンのわりには求められる要望が高い（ような気がする・・・）のですが、まぁビール飲むためには仕方ないですよね・・・。
この記事が少しでも僕と同じような立場の人にとって役立ってくれると嬉しいです（本当に
おまけ２
VBAのコードを書く際に相談したくなるかもしれません。下記にアクセスすることで運が良ければ回答が得られるかもしれません。活用してみてください。
1. この記事のコメント欄
2. callmekoheiのツイッター @calmekohei
3. Ariawaseの掲示板