質問番号:1435032470

人力検索 VBA

長い複数のURLを一度に短縮する方法はないでしょうか。

今、ExcelファイルのA1セルからA2300セルほどに、長いURLが記載されています。
長くて複数のURLを一度に短縮し、B1〜B2300セルに貼り付けたりする方法はないかと、
ここ数日、Googleで検索してかなり探してみたのですが…。
情報が古く、今現在は対応していなかったり。
ソフトウェア等もダウンロードしてみましたが、古いソフトなのか、短縮に失敗したりと。
お手上げ状態になっておりまして。
もし、今現在でも有効な、複数のURLを短縮する方法をご存じの方がいらっしゃいましたら。
お教えいただければ幸いです。
よろしくお願い致します。

Google URL Shortener API(Googleの短縮URLサービス）を利用して、プログラムを作成してみました。
なお、サンプルシートではC列に短縮したいURL、D列に短縮されたURLが出力されているので、質問内容と一部異なります。
（プログラムはThis WorkBookに記述しています。）


サンプルデータは「気象庁　気象警報・注意報　市町村ページＵＲＬ一覧」（1741件）を利用しました。

処理前手順

Google URL Shortener APIを利用するには、あらかじめAPIキーを取得する必要があります。

APIキーの取得・Google Maps API入門

　　（上記のサイトではGoogle MAPを利用する為のAPIキー取得方法を解説していますが、Google URL ShortenerもAPIキーの取得方法は同じです。）


（Google URL Shortenerのリクエスト回数は100万回／1日の制限があります。）

回答

' 回答プログラム（質問番号：1435032470）
' Author Y.Yoshiya
' Date 2015/06/24

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)     ’Sleep用

Const API_KEY As String = ""         ' Your Google API key here（APIキーは事前に取得すること）
Const BASEURL As String = "https://www.googleapis.com/urlshortener/v1/url"  ' Google Shortener URL API

Sub main()
 
    Dim BeforeURL As String
    Dim AfterURL As String
    Dim MAXROW As Integer
    Dim lp As Integer
    Dim StartTime, EndTime As Date

    Dim ErrFlag As Boolean

    Application.ScreenUpdating = False

    StartTime = Time

    With Worksheets(1)
    
        MAXROW = .Range("C" & Rows.Count).End(xlUp).Row

        ErrFlag = False
        Do While (1)
            lp = 2
            Do While lp <= MAXROW
                BeforeURL = .Range("C" & lp).Value
                If .Range("D" & lp).Value = "" Then
                    AfterURL = GetGoogleURL(BeforeURL, API_KEY)
                    .Range("D" & lp).Value = AfterURL
                End If

                If AfterURL = "" Then
                    ErrFlag = True
                End If
                lp = lp + 1
            Loop

            If ErrFlag = False Then
                Exit Do
            End If
        Loop
          
    End With

    EndTime = Time
    Debug.Print "StartTime = ", StartTime & vbCrLf & "EndTime = ", EndTime & vbCrLf & "Time =", DateDiff("s", StartTime, EndTime)

    Application.ScreenUpdating = True
   
End Sub


Function GetGoogleURL(url As String, apiKey As String) As String
  
    Dim xml As Object  ' MSXML2.XMLHTTP60
    Set xml = CreateObject("MSXML2.XMLHTTP.6.0")
 
    If xml Is Nothing Then Exit Function
 
    With xml
        .Open "POST", BASEURL & "?key=" & API_KEY, False
        .setRequestHeader "Content-Type", "application/json"
        .Send Replace("{""longUrl"": ""http://www.google.com/""}", "http://www.google.com/", url)
    End With
 
    If InStr(xml.responseText, "error") = 0 Then  ' no error occurred
        ' parse out short URL from JSON response
        GetGoogleURL = Trim$(Split(xml.responseText, """")(7))
    Else
        ' 5秒間隔を置く
        Call Sleep(5000)
        GetGoogleURL = GetGoogleURL(url, API_KEY)
    End If

End Function

Google URL Shortener APIから短縮URLを取得するサブルーチンは「Google URL Shortener API・JP SOFTWARE TECHNOLOGIES」を参照しました。
Google URL Shortener APIは、連続リクエストを行うと短縮URLが返ってこないケースがあるので、その場合5秒置いて再度リクエストを行う様にしています。

出力結果


（1741件の処理にかかった時間は、806秒でした。）

追記 2015.07.03

Tinyurlで短縮URLを出力するVBAコードを見つけましたので、上記のコードを変更してみました。
TinyurlはAPIキーが無くても利用できます。

Create Tiny URLs using VBA・Create Tiny URLs using VBA

' 回答プログラム（質問番号：1435032470）・TinyURL Ver.
' Author Y.Yoshiya
' Date 2015/07/03

Option Explicit

Sub main()
 
    Dim BeforeURL As String
    Dim AfterURL As String
    Dim MAXROW As Integer
    Dim lp As Integer
    Dim StartTime, EndTime As Date

    Dim ErrFlag As Boolean

    Application.ScreenUpdating = False

    StartTime = Time

    With Worksheets(1)
    
        MAXROW = .Range("C" & Rows.Count).End(xlUp).Row

        ErrFlag = False
        Do While (1)
            lp = 2
            Do While lp <= MAXROW
                BeforeURL = .Range("C" & lp).Value

                If .Range("D" & lp).Value = "" Then
                    AfterURL = GetTinyURL(BeforeURL)
                    .Range("D" & lp).Value = AfterURL
                End If
                
                If AfterURL = "" Then
                    ErrFlag = True
                End If
                lp = lp + 1
            Loop

            If ErrFlag = False Then
                Exit Do
            End If
        Loop
          
    End With

    EndTime = Time
    Debug.Print "StartTime = ", StartTime & vbCrLf & "EndTime = ", EndTime & vbCrLf & "Time =", DateDiff("s", StartTime, EndTime)

    Application.ScreenUpdating = True
   
End Sub


Function GetTinyURL(url As String) As String
 
    Dim xml As Object
    Set xml = CreateObject("MSXML2.XMLHTTP.6.0")
 
    If xml Is Nothing Then Exit Function

    xml.Open "POST", "http://tinyurl.com/api-create.php?url=" & url, False
    xml.Send
 
    GetTinyURL = xml.responsetext
 
End Function

出力結果

http://firestorage.jp/download/b1aa458a30621cca4e19308786f340a04d82ac67
http://firestorage.jp/download/89634fd6b29efa1a674969730c0ab7305a1dba1c