第58回複数ページのWebをさくっとまとめてスクレイピング！

2024年6月22日 21:55

今後のスケジュールはコチラ
投げ銭ページはコチラ

登壇者：りゅうりゅう@VBAer × ココナラPRO認定
日時　：2024年6月22日 21時
テーマ：「Webから」ボタン操作をマクロの記録をして、そのマクロを改良して同じサイトの複数ページにまたがった表データを連続でスクレイピングさせるってのをライブコーディングでやってみるよ！

自己紹介

URLをメモ帳に

ライブコーディング

パワク処理は2段階。パワクで取り込む上段とテーブルに変換する下段

取り込む部分の改造

ここがクエリ名

この部分の年月を変更して連続してWeb情報を取得する。

マクロ名の変更、各種変数宣言と代入

テーブル化する部分の改造

ついでにシート名も変更。

Option Explicit

Sub abWeb取り込み()
  
  Dim zl年      As String
  Dim zl月      As String
  Dim zl掲載号  As String
  
  
  zl年 = 1982
  zl月 = Format(8, "00")
  zl掲載号 = "掲載号" & zl年 & "年" & zl月 & "月"
  
  
  ActiveWorkbook.Queries.Add Name:= _
    zl掲載号, Formula:= _
    "let" & Chr(13) & "" & Chr(10) & "    ソース = Web.BrowserContents(""https://www.aabmg.com/yearbook/list.php?sY=" & zl年 & "&sM=" & zl月 & """)," & Chr(13) & "" & Chr(10) & "    #""HTML から抽出されたテーブル"" = Html.Table(ソース, {{""Column1"", ""TABLE.list > * > TR > :nth-child(1)""}, {""Column2"", ""TABLE.list > * > TR > :nth-child(2)""}, {""Column3"", ""TABLE.list > * > TR > :nth-child(3)""}, {""Column4"", ""TABLE.list > * > TR > :nth-child(4)""}}, [R" & _
    "owSelector=""TABLE.list > * > TR""])," & Chr(13) & "" & Chr(10) & "    変更された型 = Table.TransformColumnTypes(#""HTML から抽出されたテーブル"",{{""Column1"", type text}, {""Column2"", type text}, {""Column3"", type text}, {""Column4"", type text}})" & Chr(13) & "" & Chr(10) & "in" & Chr(13) & "" & Chr(10) & "    変更された型" & _
    ""
  ActiveWorkbook.Worksheets.Add
  With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array( _
    "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=""" & zl掲載号 & """;Extended Pr" _
    , "operties="""""), Destination:=Range("$A$1")).QueryTable
    .CommandType = xlCmdSql
    .CommandText = Array( _
    "SELECT * FROM [" & zl掲載号 & "]")
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .PreserveColumnInfo = True
    .ListObject.DisplayName = zl掲載号
    .Refresh BackgroundQuery:=False
  End With
  
　ActiveSheet.Name = zl掲載号
End Sub

月を8月にすれば、シートがどんどん増えるぜぇ。

年と月を引数にしてサブルーチン化

ループ処理・確認用プロシージャー

ループ処理本番

テーブルをがっちゃんこ

風柳判For～Nextバージョン

ループ処理確認用プロシージャ（別解）貼り付けておきます
Forループでもできるということで…

Sub sb確認用1()
    Dim zl年月 As Date
    Dim zl停止年月 As Date
    zl年月 = DateSerial(1982, 7, 1)
    zl停止年月 = DateSerial(1983, 1, 1)
    Do While zl年月 <= zl停止年月
        Debug.Print zl年月
        zl年月 = DateAdd("m", 1, zl年月)
    Loop
End Sub

Sub sb確認用2()
    Dim zl年月 As Date
    Dim i As Long
    zl年月 = DateSerial(1982, 7, 1)
    For i = 0 To DateDiff("m", zl年月, DateSerial(1983, 1, 1))
        Debug.Print zl年月
        zl年月 = DateSerial(Year(zl年月), Month(zl年月) + 1, 1)
    Next
End Sub