エクセルVBAでRedmineのデータを取得する
概要
Redmineのチケット数が多い場合、ページネーションされるため、無限スクロールで確認したかった。とりあえずチケットの主要な項目をエクセルで一覧できるようにしました。
抽出ボタンを押すと、同シート6行目以降にデータが書き出されます。ただし、チケット数が多きときはかなり時間が掛かります。プログレスバーを付けるべきかもです。
環境
- Windows 10
- Excel 2016
- Redmine 4.1.0
準備
- Excel
- 「リボン > 開発 > Visual Basic > ツール > 参照設定 > Microsoft XML v6.0」にチェックをする。
- リボンに開発タブが無いときは下記を参照ください。
- Redmine
- 「個人設定 > 右側のAPIアクセスキー」を確認する。
- チケットをxmlで開く、もしくはjsonで開く。
- ブラウザのURL末尾に.xmlを付ける。
- ブラウザのURL末尾に.jsonを付ける。
コード
:vba
Dim baseurl As String, targeturl As String
Dim header As Integer, row As Integer
Dim min As Integer, max As Integer
Dim cnt As Integer
Dim ticketid As String
Dim dom As Object
Dim issue As Object
baseurl = "http://redmine/"
header = 5
row = header + 1
min = 1
max = 100
cnt = min
'[A~G]欄の[row~(max-min+1)]行まで一気にクリアする
Range(Cells(row, 1), Cells(max - min + 1, 7)).Clear
Do While Cells(row, 1) = ""
ticketid = Trim(str(cnt - header))
'APIアクセスキーなし
targeturl = baseurl + ticketid + ".xml"
'APIアクセスキーあり
'targeturl = baseurl + ticketid + ".xml?key=aaaaaaaaaaaaaaaaaaaa"
Set dom = CreateObject("MSXML2.DOMDocument")
dom.async = False
dom.setProperty "ServerHTTPRequest", True
dom.Load (targeturl)
Set issue = dom.ChildNodes.Item(1)
If Not (issue Is Nothing) Then
Cells(row, 1) = issue.getElementsByTagName("id").Item(0).text
Cells(row, 2) = issue.getElementsByTagName("project").Item(0).getAttribute("name")
Cells(row, 3) = issue.getElementsByTagName("tracker").Item(0).getAttribute("name")
Cells(row, 4) = issue.getElementsByTagName("status").Item(0).getAttribute("name")
Cells(row, 5) = issue.getElementsByTagName("priority").Item(0).getAttribute("name")
Cells(row, 6) = issue.getElementsByTagName("assigned_to").Item(0).getAttribute("name")
Cells(row, 7) = issue.getElementsByTagName("subject").Item(0).text
row = row + 1
End If
cnt = cnt + 1
If cnt > max Then
GoTo 9999
End If
Loop
9999
- Excel
- 「リボン > 開発 > Visual Basic > ツール > 参照設定 > Microsoft XML v6.0」にチェックをする。
- リボンに開発タブが無いときは下記を参照ください。
- Redmine
- 「個人設定 > 右側のAPIアクセスキー」を確認する。
- チケットをxmlで開く、もしくはjsonで開く。
- ブラウザのURL末尾に.xmlを付ける。
- ブラウザのURL末尾に.jsonを付ける。
コード
:vba
Dim baseurl As String, targeturl As String
Dim header As Integer, row As Integer
Dim min As Integer, max As Integer
Dim cnt As Integer
Dim ticketid As String
Dim dom As Object
Dim issue As Object
baseurl = "http://redmine/"
header = 5
row = header + 1
min = 1
max = 100
cnt = min
'[A~G]欄の[row~(max-min+1)]行まで一気にクリアする
Range(Cells(row, 1), Cells(max - min + 1, 7)).Clear
Do While Cells(row, 1) = ""
ticketid = Trim(str(cnt - header))
'APIアクセスキーなし
targeturl = baseurl + ticketid + ".xml"
'APIアクセスキーあり
'targeturl = baseurl + ticketid + ".xml?key=aaaaaaaaaaaaaaaaaaaa"
Set dom = CreateObject("MSXML2.DOMDocument")
dom.async = False
dom.setProperty "ServerHTTPRequest", True
dom.Load (targeturl)
Set issue = dom.ChildNodes.Item(1)
If Not (issue Is Nothing) Then
Cells(row, 1) = issue.getElementsByTagName("id").Item(0).text
Cells(row, 2) = issue.getElementsByTagName("project").Item(0).getAttribute("name")
Cells(row, 3) = issue.getElementsByTagName("tracker").Item(0).getAttribute("name")
Cells(row, 4) = issue.getElementsByTagName("status").Item(0).getAttribute("name")
Cells(row, 5) = issue.getElementsByTagName("priority").Item(0).getAttribute("name")
Cells(row, 6) = issue.getElementsByTagName("assigned_to").Item(0).getAttribute("name")
Cells(row, 7) = issue.getElementsByTagName("subject").Item(0).text
row = row + 1
End If
cnt = cnt + 1
If cnt > max Then
GoTo 9999
End If
Loop
9999
:vba
Dim baseurl As String, targeturl As String
Dim header As Integer, row As Integer
Dim min As Integer, max As Integer
Dim cnt As Integer
Dim ticketid As String
Dim dom As Object
Dim issue As Object
baseurl = "http://redmine/"
header = 5
row = header + 1
min = 1
max = 100
cnt = min
'[A~G]欄の[row~(max-min+1)]行まで一気にクリアする
Range(Cells(row, 1), Cells(max - min + 1, 7)).Clear
Do While Cells(row, 1) = ""
ticketid = Trim(str(cnt - header))
'APIアクセスキーなし
targeturl = baseurl + ticketid + ".xml"
'APIアクセスキーあり
'targeturl = baseurl + ticketid + ".xml?key=aaaaaaaaaaaaaaaaaaaa"
Set dom = CreateObject("MSXML2.DOMDocument")
dom.async = False
dom.setProperty "ServerHTTPRequest", True
dom.Load (targeturl)
Set issue = dom.ChildNodes.Item(1)
If Not (issue Is Nothing) Then
Cells(row, 1) = issue.getElementsByTagName("id").Item(0).text
Cells(row, 2) = issue.getElementsByTagName("project").Item(0).getAttribute("name")
Cells(row, 3) = issue.getElementsByTagName("tracker").Item(0).getAttribute("name")
Cells(row, 4) = issue.getElementsByTagName("status").Item(0).getAttribute("name")
Cells(row, 5) = issue.getElementsByTagName("priority").Item(0).getAttribute("name")
Cells(row, 6) = issue.getElementsByTagName("assigned_to").Item(0).getAttribute("name")
Cells(row, 7) = issue.getElementsByTagName("subject").Item(0).text
row = row + 1
End If
cnt = cnt + 1
If cnt > max Then
GoTo 9999
End If
Loop
9999
xlsmファイルは下記GitHubへアップしてあります。
https://github.com/i-chiaki/RedmineToExcel.git
参考サイト
Author And Source
この問題について(エクセルVBAでRedmineのデータを取得する), 我々は、より多くの情報をここで見つけました https://qiita.com/i-chiaki/items/455a8f639126b11ca090著者帰属:元の著者の情報は、元のURLに含まれています。著作権は原作者に属する。
Content is automatically searched and collected through network algorithms . If there is a violation . Please contact us . We will adjust (correct author information ,or delete content ) as soon as possible .