Excelで「YouTube動画のリストを作って管理したい」「画像付きで一覧にしたい」そんな悩みを解決します！
リンクを貼るだけでも良さそうですが、サムネの画像があると何の動画かわかりやすいので、画像も欲しいです。でもいちいち貼り付けするのは面倒ですよね。
そして、画像をクリックしたら動画再生してくれたら・・・便利ですよね。
エクセルマクロを使えば、Youtubeのサムネ画像とリンクを埋め込めます。
今回は「エクセルにYoutubeのサムネ画像とリンクを埋め込む方法」を紹介します。
エクセルにYoutubeのサムネ画像とリンクを埋め込む方法
にエクセルにYoutubeのサムネ画像とリンクを埋め込む方法です。
１．「alt」+「F11」を押す →コード入力画面が開く →ThisWorkbookをダブルクリック
２．コードを入力
コードを入力します。
A列のリンクから、YouTubeのサムネイル画像を自動取得し、B列にサムネ画像とリンクを貼り付ける、という意味です。
３．A列にYoutubeのリンクを貼り付ける
とりあえずテレ東BIZのニュースを貼り付けてみます。
A1セルにYoutubeのリンクを貼り付けました。
４．「alt」+「F8」を同時押し →「実行」をクリック
「alt」+「F8」を同時押し →「実行」をクリックします。
５．B列にサムネ画像が貼付けできた →サムネ画像をクリック
画像サイズに合わせて、行の幅も太くしてくれます。
B列の画像をクリックすると、Youtubeが再生されます。
６．ブラウザが立ち上がり、Youtubeを再生した
リンク先のYoutubeを再生します。
「埋め込む」というより、「リンク」という感じです。
A列にリンクを入れれば、B列はまとめて処理
A列にリンクをどんどん入れてVBAを実行すれば、B列にサムネイル画像が一気に入るので、まとめて処理できてラクです。
A列にリンクを入れます。
VBA実行後。行の高さも自動で調整してくれます。
まとめ
エクセルにYoutubeのサムネ画像とリンクを埋め込む方法です。
１．「alt」+「F11」を押す →コード入力画面が開く →ThisWorkbookをダブルクリック
２．コードを入力
３．A列にYoutubeのリンクを貼り付ける
４．「alt」+「F8」を同時押し →「実行」をクリック
５．B列にサムネ画像が貼付けできた →サムネ画像をクリック
６．ブラウザが立ち上がり、Youtubeを再生した
これでYoutubeのリンクの整理も簡単ですね！
ちなみに、今回使ったコードはこちらです。
Sub InsertYouTubeThumbnailInCell()
Dim cell As Range
Dim videoID As String
Dim thumbnailURL As String
Dim pic As Picture
Dim ws As Worksheet
Dim i As Long
Dim shp As Shape
Dim linkURL As String
Dim targetCell As Range
Set ws = ActiveSheet
i = 1
Do While ws.Cells(i, 1).Value <> ""
Set targetCell = ws.Cells(i, 2)
' セルの高さと幅を調整（必要に応じて変更）
targetCell.RowHeight = 90
ws.Columns("B").ColumnWidth = 18
videoID = GetYouTubeVideoID(ws.Cells(i, 1).Value)
If videoID <> "" Then
thumbnailURL = "https://img.youtube.com/vi/" & videoID & "/0.jpg"
linkURL = "https://www.youtube.com/watch?v=" & videoID
' 既存の画像やシェイプを削除（再実行時の重複防止）
On Error Resume Next
For Each shp In ws.Shapes
If Not Intersect(shp.TopLeftCell, targetCell) Is Nothing Then
shp.Delete
End If
Next
On Error GoTo 0
' 画像挿入
Set pic = ws.Pictures.Insert(thumbnailURL)
If Not pic Is Nothing Then
With pic
.Top = targetCell.Top
.Left = targetCell.Left
.Height = targetCell.Height
.Width = targetCell.Width
.Placement = xlMoveAndSize
End With
' 透明なシェイプをかぶせてリンク設定
Set shp = ws.Shapes.AddShape(msoShapeRectangle, pic.Left, pic.Top, pic.Width, pic.Height)
With shp
.Fill.Transparency = 1
.Line.Visible = msoFalse
End With
ws.Hyperlinks.Add Anchor:=shp, Address:=linkURL
End If
End If
i = i + 1
Loop
End Sub
Function GetYouTubeVideoID(url As String) As String
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
regex.Pattern = "(?:v=|youtu\.be/)([a-zA-Z0-9_-]{11})"
regex.IgnoreCase = True
regex.Global = False
If regex.Test(url) Then
GetYouTubeVideoID = regex.Execute(url)(0).SubMatches(0)
Else
GetYouTubeVideoID = ""
End If
End Function
おまけ
ちなみに、C列にタイトルを自動取得することもできます。
コードはこちら。
Sub InsertYouTubeThumbnailsAndTitles()
Dim ws As Worksheet
Dim i As Long
Dim videoID As String
Dim thumbnailURL As String
Dim videoURL As String
Dim title As String
Dim pic As Picture
Dim shp As Shape
Dim targetCell As Range
Set ws = ActiveSheet
i = 1
Do While ws.Cells(i, 1).Value <> ""
videoID = GetYouTubeVideoID(ws.Cells(i, 1).Value)
If videoID <> "" Then
thumbnailURL = "https://img.youtube.com/vi/" & videoID & "/0.jpg"
videoURL = "https://www.youtube.com/watch?v=" & videoID
' B列：サムネイル画像
Set targetCell = ws.Cells(i, 2)
targetCell.RowHeight = 90
ws.Columns("B").ColumnWidth = 18
' 既存画像・シェイプ削除
On Error Resume Next
For Each shp In ws.Shapes
If Not Intersect(shp.TopLeftCell, targetCell) Is Nothing Then
shp.Delete
End If
Next
On Error GoTo 0
Set pic = ws.Pictures.Insert(thumbnailURL)
If Not pic Is Nothing Then
With pic
.Top = targetCell.Top
.Left = targetCell.Left
.Height = targetCell.Height
.Width = targetCell.Width
.Placement = xlMoveAndSize
End With
' 透明リンクシェイプ
Set shp = ws.Shapes.AddShape(msoShapeRectangle, pic.Left, pic.Top, pic.Width, pic.Height)
With shp
.Fill.Transparency = 1
.Line.Visible = msoFalse
End With
ws.Hyperlinks.Add Anchor:=shp, Address:=videoURL
End If
' C列：動画タイトル
title = GetYouTubeTitle(videoURL)
ws.Cells(i, 3).Value = title
End If
i = i + 1
Loop
End Sub
Function GetYouTubeVideoID(url As String) As String
Dim regex As Object
Set regex = CreateObject("VBScript.RegExp")
regex.Pattern = "(?:v=|youtu\.be/)([a-zA-Z0-9_-]{11})"
regex.IgnoreCase = True
regex.Global = False
If regex.Test(url) Then
GetYouTubeVideoID = regex.Execute(url)(0).SubMatches(0)
Else
GetYouTubeVideoID = ""
End If
End Function
Function GetYouTubeTitle(videoURL As String) As String
Dim http As Object
Dim html As String
Dim titleStart As Long, titleEnd As Long
On Error GoTo ErrHandler
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", videoURL, False
http.setRequestHeader "User-Agent", "Mozilla/5.0"
http.Send
html = http.responseText
' HTML内の<title>タグから抽出
titleStart = InStr(html, "<title>") + 7
titleEnd = InStr(html, "</title>")
If titleStart > 7 And titleEnd > titleStart Then
GetYouTubeTitle = Mid(html, titleStart, titleEnd - titleStart)
' タイトル末尾の " - YouTube" を削除
GetYouTubeTitle = Replace(GetYouTubeTitle, " - YouTube", "")
Else
GetYouTubeTitle = "(タイトル取得失敗)"
End If
Exit Function
ErrHandler:
GetYouTubeTitle = "(エラー)"
End Function
※注：インターネットにつながってないと、うまくいきません。
Youtubeからうまくタイトルが取れない場合もあります。
コメント