Htmlテーブルの接続

Excelにはデータの接続という機能があります。これはデータベースやテキストファイル等のデータとリンクされた表をExcelシート上に展開する機能です。この機能を使うことでExcel形式では無いデータや閲覧のみで渡したいデータ等を効率的に利用することができます。この中でインターネット上の表(Table要素)を展開することも出来るのですが、Windows版とMac版では最初に設定する際の挙動が少し違います。

Windows版とMac版の違い

Windows版ではURLのインプットダイアログが表示され、URLを入力することで次のステップに進むのですが、Mac版ではURLの直接入力はできず、iqyという見慣れない拡張子の付いたファイルを選択する必要があります。またこのiqyファイルは特定のディレクトリに保存されている必要があります。

このiqyファイルはURLを入力しただけのテキストファイルです。なぜMac版だけこの仕様なのかは不明ですが、Windows版と比べると手間が多いのは間違いありません。それに初めて使う場合は面を喰らい、iqyという見慣れないファイルのせいでこの機能の利用自体を忌避されかねません。

VBAでショートカット

ならば、無い機能はVBAでつくるの精神でiqyファイルを自動作成し、少しでもWindows版に近づけてみましょう。流れとしては以下のとおりです。

インプットダイアログでURLを入力
入力されたURLをiqyファイルとしてカレントディレクトリに保存
2を元にデータの接続を設定する

では実際のコードは以下のとおりです。

Sub addHtmlTable()
Dim cmd As String, qname As String

cmd = Application.InputBox(prompt:="URLを入力して下さい。", Title:="WEBのテーブルに接続", Type:=2)
If cmd <> "" And cmd <> "False" Then
    qname = getQueryName(cmd)　'ファイル名の決定
    If Not Application.OperatingSystem Like "*Mac*" Then
        cmd = "URL;" & cmd 'Windowsではそのまま
    Else
        Dim path As String, iqy As String　'Macではiqyファイル作成
        path = getQuerypath() & qname & ".iqy" '特定のディレクトリパスは以下のFunctionに表記
        iqy = cmd
        Open path For Output As #1
            Print #1, iqy
        Close #1
        cmd = "FINDER;" & path
    End If
    Application.CutCopyMode = False
    With ActiveSheet.QueryTables.Add(Connection:=cmd, Destination:=Range("$A$1"))
        .name = qname
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "1"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End If
End Sub

'ファイル名の決定
Function getQueryName(ByVal url As String) As String
Dim qname As String

qname = Replace(url, "https://", "")
qname = Replace(qname, "http://", "")
qname = Replace(qname, ".", "-")
qname = Replace(qname, "/", "_")
If Len(qname) > 30 Then
    qname = Left(qname, 30)
End If
getQueryName = qname

End Function

'特定のディレクトリパス
Function getQuerypath() As String
Dim cpath As String: cpath = ThisWorkbook.path
Dim roots() As String
Dim querypath As String

roots = Split(cpath, "/Documents/")
querypath = roots(0) & "/Library/Group Containers/UBF8T346G9.Office/User Content.localized/Queries/"
getQuerypath = querypath

End Function