【Excel】複数のWebページ・サイトのデータを一括収集する

Sub ImportTablesWithPowerQuery()
    ' Written by consulting-campus.site
    '
    '
    '
    Dim ws As Worksheet
    Dim int_LastRow As Long
    Dim i As Long
    Dim str_URL As String, str_QueryName As String, str_Formula As String
    Dim int_TabelNum As Integer

    ' エクセルの高速化
    Call fml_ExcelVbaStart

    ' アクティブワークシートを設定
    Set ws = ThisWorkbook.ActiveSheet

    ' A列の最後の行を取得
    int_LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' 2行目から最後の行まで繰り返し処理を行う
    For i = 2 To int_LastRow
        str_URL = ws.Cells(i, 1).Value
        int_TabelNum = ws.Cells(i, 2).Value - 1
        str_QueryName = ws.Cells(i, 3).Value

        ' パワークエリで実行する処理を記述
        str_Formula = "let" & Chr(13) & _
                  "    Source = Web.Page(Web.Contents(""" & str_URL & """))," & Chr(13) & _
                  "    Data = Source{" & int_TabelNum & "}[Data]" & Chr(13) & _
                  "in" & Chr(13) & _
                  "    Data"

        ' クエリを作成/更新
        With ThisWorkbook.Queries.Add(Name:=str_QueryName, formula:=str_Formula)
            .Description = "Query created from row " & i
        End With

        ' クエリをワークシートにロード
        ThisWorkbook.Worksheets.Add
        ActiveSheet.Name = str_QueryName
        ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
            "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & str_QueryName & ";Extended Properties=""""" _
            , Destination:=Range("$A$1")).QueryTable.CommandType = xlCmdSql
        ActiveSheet.ListObjects(1).QueryTable.CommandText = "SELECT * FROM [" & str_QueryName & "]"
        ActiveSheet.ListObjects(1).QueryTable.Refresh BackgroundQuery:=True
    Next i

    ' 高速化処理のリセット
    Call fml_ExcelVbaEnd

    MsgBox ("完了しました")
End Sub

Sub fml_ExcelVbaStart()
    Application.ScreenUpdating = False            '画面更新の停止
    Application.Cursor = xlWait                   'カーソルの停止
    Application.EnableEvents = False              'イベントの停止
    Application.DisplayAlerts = False             'アラートの停止
    Application.Calculation = xlCalculationManual '自動計算の停止
End Sub

Sub fml_ExcelVbaEnd()
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
End Sub

Sub ImportTablesWithPowerQuery()
    ' Written by consulting-campus.site
    '
    '
    '
    Dim ws As Worksheet
    Dim int_LastRow As Long
    Dim i As Long
    Dim str_URL As String, str_QueryName As String, str_Formula As String
    Dim int_TabelNum As Integer

    ' エクセルの高速化
    Call fml_ExcelVbaStart

    ' アクティブワークシートを設定
    Set ws = ThisWorkbook.ActiveSheet

    ' A列の最後の行を取得
    int_LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    ' 2行目から最後の行まで繰り返し処理を行う
    For i = 2 To int_LastRow
        str_URL = ws.Cells(i, 1).Value
        int_TabelNum = ws.Cells(i, 2).Value - 1
        str_QueryName = ws.Cells(i, 3).Value

        ' パワークエリで実行する処理を記述
        str_Formula = "let" & Chr(13) & _
                  "    Source = Web.Page(Web.Contents(""" & str_URL & """))," & Chr(13) & _
                  "    Data = Source{" & int_TabelNum & "}[Data]" & Chr(13) & _
                  "in" & Chr(13) & _
                  "    Data"

        ' クエリを作成/更新
        With ThisWorkbook.Queries.Add(Name:=str_QueryName, formula:=str_Formula)
            .Description = "Query created from row " & i
        End With

        ' クエリをワークシートにロード
        ThisWorkbook.Worksheets.Add
        ActiveSheet.Name = str_QueryName
        ActiveSheet.ListObjects.Add(SourceType:=0, Source:= _
            "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & str_QueryName & ";Extended Properties=""""" _
            , Destination:=Range("$A$1")).QueryTable.CommandType = xlCmdSql
        ActiveSheet.ListObjects(1).QueryTable.CommandText = "SELECT * FROM [" & str_QueryName & "]"
        ActiveSheet.ListObjects(1).QueryTable.Refresh BackgroundQuery:=True
    Next i

    ' 高速化処理のリセット
    Call fml_ExcelVbaEnd

    MsgBox ("完了しました")
End Sub

Sub fml_ExcelVbaStart()
    Application.ScreenUpdating = False            '画面更新の停止
    Application.Cursor = xlWait                   'カーソルの停止
    Application.EnableEvents = False              'イベントの停止
    Application.DisplayAlerts = False             'アラートの停止
    Application.Calculation = xlCalculationManual '自動計算の停止
End Sub

Sub fml_ExcelVbaEnd()
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
End Sub