はじめに

これは、Visual Basic Advent Calendar 2020とSpreadsheets/Excel Advent Calendar 2020の19日目の記事となります。
間に合わなかったので1日遅れになりました。

以前、「【Python】Youtube Data Apiを使ってYouTube 動画コメントを全取得する」の記事を書きました。
Excelでも出来るかなと思って今回やってみました。

環境

Windows 10 Home
Microsoft Office 365 の Excel
VBA-JSON v2.3.1
Microsoft Scripting Runtime

VBA-JSON

VBAではJSONをパースする標準ライブラリがないので、VBA-JSONを利用します。
https://github.com/VBA-tools/VBA-JSON

Releasesから最新版(2020/12/19現在 v2.3.1)のVBA-JSONのリンクをクリックします。
Source code(zip) をダウンロードして展開します。
JsonConverter.basをVBAのプロジェクトにインポートします。
導入方法はVBAエディターを開き、プロジェクトウィンドウでVBAProjectを右クリックしファイルのインポートをクリックします。
標準モジュールにJsonConverterが表示されれば、VBA-JSONの導入は完了です。

図入りの説明が必要なら下記サイトを参照してください。
【VBA】Backlog APIで課題を操作する

Microsoft Scripting Runtime

VBEメニューの [ ツール ] から [ 参照設定 ] を選択する。
表示された参照設定ダイアログから "Microsoft Scripting Runtime" にチェックを入れて[ OK ] ボタンをクリックする。

仕様

コメントのフォーマットはhtmlかplain textがあるのですが、plain textになっています。
並び順はrelevanceで評価順が多い順にしています。子コメントについては順不動（並び順を指定しても動画サイトと同じにならない）です。

※APIの使用回数を減らすため親コメントはmaxResults=100、子コメントはmaxResults=50とする。
※コメントでは低評価(disLike)数は取得できない。

(連番)         (親コメント) （グッド数） （投稿者名） （投稿日時) （返信数)
(連番) (子連番) (子コメント) （グッド数） （投稿者名） （投稿日時)

【2021/05/28追記】
並び順を評価順(relevance)にした場合、YouTube Data API v3の制約上2000件を超える親コメントが取得できません。
並び順を新しい順(time)にした場合、上限が不明ですが2000件を超える親コメントが取得できます。

使用方法

標準モジュールに、Constキーワードで'API_KEY'と'Video ID'を定義しているので変更してください。
VBAが出来る方なら、シートのセルに入力欄を作って変更できるようにすると楽になると思います。

Module1.bas

'ここにAPI KEYを入力
Const API_KEY = "(API KEYを入力)"

'ここにVideo IDを入力
Const VIDEO_ID = "(Video IDを入力)"

私は、Sheet2にコマンドボタンを用意して、クリックしたらCall GetYoutubeCommentを呼ぶようにしています。
それか、マクロ実行でGetYoutubeCommentを実行すればいいです。
Sheet１にコメントが出力されます。

API_KEYを入力

Youtube Data APIのAPI有効化の認証情報でAPIキーが発行されるので、プログラムのAPI_KEYを入力で発行されたAPIキーに書き換えてください。

Video IDを入力

例えば、「https://www.youtube.com/watch?v=oeJ_b0iG9lM」であれば、oeJ_b0iG9lMがVideo IDとなりますので、プログラムのVideo IDを入力で対象動画のVideo IDに書き換えてください。

プログラム

Module1.bas

Option Explicit

Const URL = "https://www.googleapis.com/youtube/v3/"

'ここにAPI KEYを入力
Const API_KEY = "(API KEYを入力)"

'ここにVideo IDを入力
Const VIDEO_ID = "(Video IDを入力)"

Sub コメント取得_Click()

    Call GetYoutubeComment

End Sub

' YouTube動画コメント全取得
Public Sub GetYoutubeComment()

    Dim row As Integer
    Dim header As Variant

    Sheets(1).Activate
    ActiveSheet.Cells.Clear

    ' ヘッダー
    header = Array("連番", "子連番", "コメント", "グッド数", "投稿者名", "投稿日時", "返信数")
    row = 1
    Call Output(row, ActiveSheet, header)

    Call GetComment(row, ActiveSheet)

End Sub

' コメント取得
Private Sub GetComment(ByVal row As Integer, ByVal sh As Worksheet)

    Dim no As Integer, cno As Integer, json As Object
    Dim text As String, like_cnt As Integer, user_name As String, post_date As Date
    Dim total_reply_cnt As Integer, parentID As String
    Dim params As Object, item As Object
    Dim values As Variant

    Set params = CreateObject("Scripting.Dictionary")

    With params
        .Add "key", API_KEY
        .Add "part", "snippet"
        .Add "videoId", VIDEO_ID
        .Add "order", "relevance"
        .Add "textFormat", "plaintext"
        .Add "maxResults", "100"
        .Add "pageToken", ""
    End With

    no = 1
    Do While True
        Set json = KickWebApiOfJson("GET", URL & "commentThreads", params)

        For Each item In json("items")
            ' コメント
            text = CStr(item("snippet")("topLevelComment")("snippet")("textDisplay"))
            ' グッド数
            like_cnt = CInt(item("snippet")("topLevelComment")("snippet")("likeCount"))
            ' ユーザー名
            user_name = CStr(item("snippet")("topLevelComment")("snippet")("authorDisplayName"))
            ' 投稿日時
            post_date = JsonDateToDate(item("snippet")("topLevelComment")("snippet")("publishedAt"))
            ' 総返信数
            total_reply_cnt = CInt(item("snippet")("totalReplyCount"))
            ' 親ID
            parentID = CStr(item("snippet")("topLevelComment")("id"))

            values = Array(no, "", text, like_cnt, user_name, post_date, total_reply_cnt)
            Call Output(row, sh, values)

            If total_reply_cnt > 0 Then
                Call GetReplyComment(parentID, no, row, sh)
            End If
            no = no + 1
        Next

        params("pageToken") = CStr(json("nextPageToken"))
        If params("pageToken") = "" Then
            Exit Do
        End If
    Loop

End Sub

' 返信コメント取得
Private Sub GetReplyComment(ByVal parentID As String, ByVal no As Integer, ByRef row As Integer, ByVal sh As Worksheet)

    Dim cno As Integer, json As Object
    Dim text As String, like_cnt As Integer, user_name As String, post_date As Date
    Dim params As Object, item As Object
    Dim values As Variant

    Set params = CreateObject("Scripting.Dictionary")

    With params
        .Add "key", API_KEY
        .Add "part", "snippet"
        .Add "videoId", VIDEO_ID
        .Add "textFormat", "plaintext"
        .Add "maxResults", "50"
        .Add "pageToken", ""
        .Add "parentId", parentID
    End With

    cno = 1
    Do While True
        Set json = KickWebApiOfJson("GET", URL & "comments", params)

        For Each item In json("items")
            ' コメント
            text = CStr(item("snippet")("textDisplay"))
            ' グッド数
            like_cnt = CInt(item("snippet")("likeCount"))
            ' ユーザー名
            user_name = CStr(item("snippet")("authorDisplayName"))
            ' 投稿日時
            post_date = JsonDateToDate(item("snippet")("publishedAt"))

            values = Array(no, cno, text, like_cnt, user_name, post_date)
            Call Output(row, sh, values)
            cno = cno + 1
        Next

        params("pageToken") = CStr(json("nextPageToken"))
        If params("pageToken") = "" Then
            Exit Do
        End If
    Loop

End Sub

' Excelシートに出力
Private Sub Output(ByRef row As Integer, ByVal sh As Worksheet, ByVal values As Variant)

    Dim i As Integer

    For i = 0 To UBound(values)
        sh.Cells(row, i + 1).Value = values(i)
    Next
    row = row + 1

End Sub

' JSON日付変換
Private Function JsonDateToDate(ByVal dt As String) As Date

    JsonDateToDate = CDate(Replace(Mid(dt, 1, 16), "T", " "))

End Function

' クエリ文字列変換
Private Function ConvertToQueryString(ByVal dic As Object) As String

    If dic Is Nothing Then Exit Function
    Dim key As Variant
    Dim str As String
    str = ""
    For Each key In dic.Keys
        ConvertToQueryString = ConvertToQueryString & str & key & "=" & dic.item(key)
        str = "&"
    Next

End Function

' WebAPI取得
Function KickWebApiOfJson(ByVal request As String, ByVal URL As String, Optional ByVal param As Object) As Object
    Dim json
    json = ConvertToQueryString(param)

    Dim http As Object
    Set http = CreateObject("MSXML2.ServerXMLHTTP")
    With http
        .Open request, URL & "?" & json, False
        .SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
        .send

        If .ResponseText <> "" Then
            Set KickWebApiOfJson = ParseJson(.ResponseText)
        End If
    End With
End Function

実行結果

郡司りかさんを御存知でしょうか？
マツコ・デラックスさんと村上信五（関ジャニ∞）さんがMCの「月曜から夜更かし」の中で、運動音痴として注目を浴びた女性です。
郡司りかさんはYoutubeとTwitterをやられており、ツイート画像に「おはよー」を隠すという遊びをしています。
郡司りかさんのツイート画像の「おはよー」を見つける

「【NiziU】郡司さんMake You Happyにチャレンジ (練習前)」の動画コメントを取得すると、下記のようになります。

悩んだところ

YouTube Data Apiの呼び出し

sendのところにクエリパラメーターを指定すると、エラーコード 403、エラーメッセージ「The request is missing a valid API key.」で取得できなかったんですよね。
何か悪さしているんだろうけど、分からなかったです。
最終的に「URL & "?" & json」のようにクエリパラメーターを文字列連結して対応しました。

.Open request, URL, False
.SetRequestHeader "Content-Type", "application/json; charset=UTF-8"
.send json

返信コメントの取得

返信コメントは５件までだったら、item("snippet")("replies")("comments")の配下で取得出来るはずなんですが、駄目でした。取得できるならもう少し高速化できたんですけどね。

Google App Scriptでは取得出来るので、VBA-JSON側で取れないのかも知れません。
Google Apps ScriptとYoutubeのAPIを利用して動画のコメントを取得する

最後に

VBA-JSONは、素晴らしいライブラリです。Excelでjson扱うんだったら素直に使った方がいいです。
Macのofficeを持っているのですがMacだとActiveXが使えません。「Microsoft Scripting Runtime」はDictionary型を使用するのに必要で、代わりになるものとして、VBA-toolsにVBA-Dictionaryがあります。
今度は、MacのOfficeで同じことが出来るのか試してみたいと思います。

【2020/12/21追記】
Mac版を作成しました。
【VBA】Excel for MacでYoutube Data Apiを使ってYouTube 動画コメントを全取得する

【VBA】ExcelでYoutube Data Apiを使ってYouTube 動画コメントを全取得する