利用者:Junknote/コンテンツ翻訳の記事一覧作成VBA

特徴

エクセル単体でコンテンツ翻訳の記事一覧を取得します。

使い方

標準モジュールに貼り付けて実行します。InputBoxへ日付を入力すると、その日以降のコンテンツ翻訳の記事を500件まで取得します。Sheet(1)に記事名、立項者、立項日、要約欄などの一覧、Sheet(2)にWikipediaへ貼付するための成形済みリストが生成されます。

ソース

‎

Option Explicit
Public Sub GET_Cx_Article()
    Dim strURL As String
    Dim strHtml As String
    Dim strTime As String
    Dim xmlHttp As Variant
    Dim Buf() As String
    Dim strSpText() As String
    Dim i As Long
    Dim lngStart As Long
    Dim Data(1 To 501, 1 To 5) As Variant 'データ格納用（最大のヘッダ+500データ分）
    strTime = InputBox("取得したい日付を指定してください。" & vbCrLf & "フォーマットは「YYYY-MM-DD」です。", "logevents")
    If Len(strTime) = 0 Then Exit Sub
    strTime = strTime & "T00:00:00Z"
    strURL = "https://ja-two.iwiki.icu/w/api.php?action=query&format=json&list=logevents&utf8=1&ledir=newer&lenamespace=0&letag=contenttranslation&leprop=title%7Ctimestamp%7Cuser%7Ccomment%7Ctags&letype=create&lelimit=max&lestart=" & strTime
    Set xmlHttp = CreateObject("Msxml2.XMLHTTP")
    xmlHttp.Open "GET", strURL, False
    xmlHttp.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
    xmlHttp.send
    strHtml = xmlHttp.responseText
    Set xmlHttp = Nothing
    'データがなければ終了
    If InStr(strHtml, "翻訳により作成") = 0 Then
        MsgBox "取得可能なデータはありません", vbInformation
        Exit Sub
    End If
    Buf = Split(strHtml, "{")  ' {で分割
    lngStart = 1 '開始位置の初期化
    Do Until InStr(Buf(lngStart), "翻訳により作成") <> 0
        lngStart = lngStart + 1
    Loop
    For i = lngStart To UBound(Buf())
        strSpText = Split(Buf(i), Chr(34) & Chr(44) & Chr(34))  ' ","で分割
        'strSpText(0)の17文字目からが記事名
        Data(i - lngStart + 2, 1) = Mid$(strSpText(0), 17, Len(strSpText(0)) - 16)
        'strSpText(1)の8文字目からが立項者名
        Data(i - lngStart + 2, 2) = Mid$(strSpText(1), 8, Len(strSpText(1)) - 7)
        'strSpText(2)の右から20文字がタイムスタンプ
        Data(i - lngStart + 2, 3) = Left$(Right$(strSpText(2), 20), 10)
        'strSpText(3)の11文字目からが要約欄（18から19文字目が翻訳元の言語略称）
        Data(i - lngStart + 2, 4) = Mid$(strSpText(3), 11, Len(strSpText(3)) - 1)
        Data(i - lngStart + 2, 5) = "# {{Page|" & Data(i - lngStart + 2, 1) & "}}(" & Mid$(Data(i - lngStart + 2, 4), 8, 2) & "):"
    Next i
    Data(1, 1) = "記事名"
    Data(1, 2) = "立項者"
    Data(1, 3) = "立項日"
    Data(1, 4) = "要約欄"
    Data(1, 5) = "リスト"
    With ThisWorkbook.Sheets(1)
        .Range(.Cells(1, 1), .Cells(501, 5)) = Data
    End With
    Call GET_Cx_List
End Sub
Private Sub GET_Cx_List()
    Dim varDay As Variant
    Dim varList As Variant
    Dim ws As Worksheet
    Dim lngRow As Long
    Dim i As Long
    Dim strDay As String
    With ThisWorkbook.Sheets(1)
        lngRow = .Cells(Rows.Count, 1).End(xlUp).Row
        varDay = .Range(.Cells(2, 3), .Cells(lngRow, 3))  '日付の配列
        varList = .Range(.Cells(2, 5), .Cells(lngRow, 5)) '貼付用リストの配列
    End With
    Set ws = Worksheets.Add
    Call ws.Move(After:=Sheets(Sheets.Count))
    strDay = varDay(lngRow - 1, 1) '一番下の日付を格納
    For i = lngRow - 1 To 1 Step -1
        If strDay = varDay(i, 1) Then
            ws.Cells(i, 1) = varList(i, 1)
        Else
            ws.Rows(i).Insert Shift:=xlDown
            ws.Cells(i + 1, 1).NumberFormatLocal = "@"
            ws.Cells(i + 1, 1) = "=== " & Month(strDay) & "月" & Day(strDay) & "日 ==="
            ws.Cells(i, 1) = varList(i, 1)
            strDay = varDay(i, 1)
        End If
    Next i
    ws.Rows(1).Insert Shift:=xlDown
    ws.Cells(1, 1).NumberFormatLocal = "@"
    ws.Cells(1, 1) = "=== " & Month(strDay) & "月" & Day(strDay) & "日 ==="
End Sub