EXCEL VBA でセルにあるURL一覧から一括情報取得したい

こんにちは、VBAを勉強していて、もう何時間も同じところで躓いており、お力をおかしいただけたらと思います。

EXCELのシートC2から下に向け１００前後のURL一覧があり、各URLを開いて情報を取得しています。開くURLを直接書き込むやり方だとなんとか取れたのですが、これだと各URLをいちいち書き込まなければならず、煩雑です・・。なのでURLを書き込まず変数などにして、各URLに対して情報取得を一括でできないかと思っています。

●●できているマクロ（開くURLを直接書いているもの）●●
サブルーティンを３つつけ、一番下にメインをかいてあります。これらは本4冊とWEBの情報を参考になんとかここまではできました。

#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long)
#End If

'----------------------------------------------------------------
'①指定URLを表示するサブルーチン「ieView」
Sub ieView(objIE As InternetExplorer, _
urlName As String, _
Optional viewFlg As Boolean = True)

'IE(InternetExplorer)のオブジェクトを作成する
Set objIE = CreateObject("InternetExplorer.Application")

'IE(InternetExplorer)を表示・非表示
objIE.Visible = viewFlg

'指定したURLのページを表示する
objIE.navigate urlName

'IEが完全表示されるまで待機
Call ieCheck(objIE)

End Sub

'----------------------------------------------------------------
'②Webページ完全読込待機処理サブルーチン「ieCheck」
Sub ieCheck(objIE As InternetExplorer)

Dim timeOut As Date

timeOut = Now + TimeSerial(0, 0, 20)

Do While objIE.Busy = True Or objIE.readyState <> 4
DoEvents
Sleep 1
If Now > timeOut Then
objIE.Refresh
timeOut = Now + TimeSerial(0, 0, 20)
End If
Loop

timeOut = Now + TimeSerial(0, 0, 20)

Do While objIE.document.readyState <> "complete"
DoEvents
Sleep 1
If Now > timeOut Then
objIE.Refresh
timeOut = Now + TimeSerial(0, 0, 20)
End If
Loop

End Sub
'②お気に入りやアクセス数を変数にするもの

Function classValue(objIE As InternetExplorer, _
className As String, _
tagName As String, _
valueType As String) As String

For Each objDoc In objIE.document.getElementsByClassName(className)

With objDoc

  If LCase(.nodeName) = tagName Then

    Select Case valueType

      Case "innerHTML"

        classValue = .innerHTML

      Case "innerText"
         
        classValue = .innerText
  
      Case "outerHTML"

        classValue = .outerHTML

      Case "outerText"

        classValue = .outerText

    End Select

    Exit For

  End If

End With

End Function

'メインここから----------------------------------------------------------------

Sub sample()

Dim objIE As InternetExplorer

'本サイトをIE(InternetExplorer)で起動
Call ieView(objIE, "https://www.111.com/news/22831458/")

'Aデータを抽出しI2へ
Range("I2").Value = objIE.document.getElementById("tabmenu_inqcnt").innerText

'Bデータを抽出しG2へ

Range("G2").Value = classValue(objIE, "ac_count", "span", "innerText")

'Cデータを抽出しH2へ

Range("H2").Value = classValue(objIE, "fav_count", "span", "innerText")

'画像ファイル名を抽出しK2へ

Range("K2").Value = objIE.document.images(58).src

End Sub

###試したこと
https://qiita.com/Nao3/items/37f84f1777cd8229b915
↑この情報をもとに書き換えるも、うまく動作せず。

###完成イメージ
URLを開くところから各情報取得→各セルへのインプットまでをループにして、URL一覧がなくなったら終了という形にしたいです。あとループにした場合、データ抽出部分をどのように書き換えるかもわからず苦戦しております・・

お力をお貸しいただけたらと思います。どうぞ宜しくお願いいたします。

###補足情報(EXCEL2016,Windows10,64bit )

行動規範の内容に同意します

回答1件

ベストアンサー

セル値からURL取得

まずはセル値からURLを取得する方法について。
例えばC2セルにURL https://www.111.com/news/22831458/　が入力してあり、このURLをieView関数で開くのであれば、Call ieView(objIE, Cells(2,"C").Value)という記述で実現できます。

こうすると、それ以降は今のロジックのままで、C2からURLを取得して同じ行のI/G/H/K列に書きだすような処理になりますよね。
出力側に少し手を加えるとすれば、Range関数は複数セルを指定できる記述ですが、今回は単一セルしか指定していません。
単一セルを扱うのであればCellsの方が扱いやすいです。
たとえばRange("I2").ValueはCells(2,9).ValueまたはCells(2,"I").Valueと記述できます。
行番号が文字列の一部ではなくなるので、変数でループ処理することも簡単になります。

対象となるセルを順次取得する

次に課題となるのは、URLが入力されているセルの値をループ処理で順次取得する方法だと思います。
ループの範囲の決め方は例えば
・2行目～100行目までをループ処理する（固定範囲のループ）
・2行目以降、URLが連続で入力されている範囲をループ処理する
・2行目以降、URLが入力されている最終行までをループ処理する
といったようにいくつかあるのですが、ここでは３つ目に紹介した２行目～最終データ行ということで話を進めたいと思います。

C列の最終データ行はCells(Rows.Count, "C").End(xlUp).Rowといった記述で実現できます。
解説すると、Rows.Countはそのバージョンのエクセルで利用できる最大の行番号を返します。
.End(XlUp)というのは、対象セルから「Ctrl」+「↑」を操作したセル位置となります。
つまり、C列の最終行から「Ctrl」＋「↑」を操作した位置の行番号を返す、というわけです。

「Ctrl」＋「↑」の操作をすると、対象セルから上方向に向かって最初に見つけたデータがあるセルに移動します。
なので、C列最終行から上に向かってデータを探していき、最初に見つけた行の行番号を返す⇒最終データ行の行番号を返すという訳です。

これを使って２行目から最終データ行までのループを行えば目的の動作が実現すると思います。

Dim iRow As Integer
For iRow = 2 To Cells(Rows.Count, "C").End(xlUp).Row
    '本サイトをIE(InternetExplorer)で起動
    Call ieView(objIE, Cells(iRow, "C").Value)
    
    'Aデータを抽出しI2へ
    Cells(iRow, "I").Value = objIE.document.getElementById("tabmenu_inqcnt").innerText
    
    '（--以下略--）
    
Next

参考になれば幸いです。
がんばってみてください。

投稿2017/10/03 10:14