Redashの結果をそのままExcelに流し込むVBA

これはなに？

Redashは便利なんですが、どうしてもExcelで加工したいなどのニーズはまだまだ残っていると思います。
以前、いちいちRedashからデータをコピペしなくて済む方法を記事にしましたが、その方法では50シート目あたりから辛くなってきてメモリ不足で落ちるようになりました。

参考：
Redashのデータを毎日エクセルへコピペしている人へささげる -APIを利用した自動更新方法-
http://qiita.com/aomegane/items/63f0a5086fd045ee0067

ということで、もうVBAを書くしかない！ということでVBAを書いてみました。

ソースコード

設計

1. 同名の
2. RedashのAPIを叩き、CSVを取得する
3. CSVをパースしてシートに書き込む

ということをしています。

コード

Sub Main()
    'RedashAPIを使用するための変数
    Const ApiToken = "YOUR-API-KEY"
    Dim Url As String
        
    '取り込むRedashのQueryIdを定義する
    TargetQueryIds = Array("939", "1434", "879", "806", "1042", "1337", "876", "895", "897", "1338", "1339", "833", "885", "835", "1568", "1002", "1408")
    
    'Queryごとにループを回す
    For Each tqid In TargetQueryIds
        Url = "https://YOUR-REDASH-URL/api/queries/" + tqid + "/results.csv?api_key=" + ApiToken
        
        'Redash のAPIを叩き 結果をCSVとして取得する
        Dim ResultCsv As String
        ResultCsv = GetContents(Url)
        
        '同名称のシートがあれば削除し、新しいシートにデータを保存する
        MakeRefreshedSheet (tqid)
        CsvToSheet (ResultCsv)
    Next
End Sub

'ReadshのAPIを叩いてCSVで返す
Function GetContents(Url As String) As String
    Dim XmlHttp As Object
    Set XmlHttp = CreateObject("MSXML2.XMLHTTP")
    XmlHttp.Open "GET", Url, False
    XmlHttp.Send
    GetContents = XmlHttp.ResponseText
End Function

'CSVをシートに書き込む
Function CsvToSheet(ResultCsv As String)
    StringLines = Split(ResultCsv, vbCrLf) '改行コードでSplitして行に分割する
    i = 0
    For Each sl In StringLines '1行ずつ処理
        CellValues = Split(sl, ",")
        j = 0
        For Each c In CellValues  '1列ずつ処理
            Cells(i + 1, j + 1).Value = c
            j = j + 1
        Next
        i = i + 1
    Next
End Function

'同名のシートがあれば削除し、新規のシートをつくる
Function MakeRefreshedSheet(sname As String)
     If ExistsWorksheet(sname) Then
        Application.DisplayAlerts = False
        Worksheets(sname).Delete
        Application.DisplayAlerts = True
     End If
     Set wSheet = Worksheets.Add
     wSheet.name = sname
End Function

'ワークシートの存在チェックを返す
Function ExistsWorksheet(sname As String)
    Dim ws As Worksheet
    For Each ws In Sheets
        If ws.name = sname Then '存在する => True
            ExistsWorksheet = True
            Exit Function
        End If
    Next
    ExistsWorksheet = False '存在しない => False
End Function

ハマりどころ

RedashのjsonAPIは列の並び順が画面と異なる
なので今回はCSVを返すAPIを利用することにしました

画面