VB(#8) ニコニコ動画のソート情報を収集するExcel用マクロｗ

VB で IE 操作に挑戦をしていたのですが、うまくいかず、それでは 最初から集計目的で、Excel にデータを収集するものとして、こんなマクロを作ってみましたｗ

Windows7 + Excel2002 の環境で作っているので、使える人はいるのでしょうか？

なお、お約束ですが、使用にあったっては自己責任でお願いしますｗ

何があっても、文句や泣き言は無しですｗ

保存先(OneDrive)

http://1drv.ms/1wFRRP7


最初の画面ですｗ

①カテゴリー（例：踊ってみた）、②ソート条件（例：マイリスが多い順）、③データ収集のページ数（Max.62）を設定し、「スタートボタン」をクリックｗ




データを収集した結果ｗ




sheet2 では、sheet1 のメニュー項目の設定や、VBAで使用する参照先や変数等を作ったりしていますｗ

動画説明ｗ




懐かしいランキング動画ｗ
http://www.nicovideo.jp/mylist/16720797


以下、VBAのきたないソースｗ
なんたって初めて2週間しか、経ってませんから、大目に見てあげてくださいｗ

＜VBAソース＞
Private Sub CommandButton1_Click()

Dim objIE As Object
Dim strHtlm As String
Dim URL As String
Dim TXT As String
Dim doc As Object
Dim ret As Long
Dim i As Long

Dim dataQuantity As Long
Dim repeatNumber As Long
Dim n As Integer

Dim m As Long
Dim k As Integer

Dim strValue As String

'検索結果画面のクリア
Range(Cells(5, 4), Cells(65536, 13)).Clear

Range(Cells(5, 4), Cells(65536, 4)).NumberFormatLocal = "dd/mm/yy hh:mm"
With Range(Cells(5, 4), Cells(65536, 4))
.HorizontalAlignment = xlCenter
End With

'指定のURLを表示する
URL = Worksheets("Sheet2").Cells(3, 11).Value
TXT = ThisWorkbook.Path & "\objIE_Source.txt"

Set objIE = CreateObject("InternetExplorer.Application")
objIE.Visible = True
objIE.Navigate (URL)

Call WaitFor(5)

'「objIE_Source.txt」にサイトのソースを記録する
Set doc = objIE.document
strHtml = doc.DocumentElement.outerhtml
strHtml = Replace(strHtml, vbLf, vbCrLf)

i = FreeFile
Open TXT For Output As i
Print #i, strHtml
Close #i

'「Notepad」を開いて、サイトのソースを表示する
'ret = Shell("Notepad.Exe " & TXT, vbNormalFocus)

'データ取得件数の保存（ページ数ｘ32）
dataQuantity = 32 * Cells(24, 2).Value

Worksheets("Sheet1").Range(Cells(2, 10), Cells(2, 12)).Copy Worksheets("Sheet1").Range(Cells(5, 10), Cells(dataQuantity + 4, 10))

'データ取得件数の限度チェック
If dataQuantity > 2000 Then
dataQuantity = 2000
End If

k = "0"

DataCollection:

'データ取得件数のチェック
If dataQuantity > 32 Then
repeatNumber = 32
Else: repeatNumber = dataQuantity
End If

dataQuantity = dataQuantity - 32

'データ取得の処理
For n = 1 To repeatNumber Step 1
strValue = objIE.document.getElementsByClassName("itemTime")(n - 1).innerText 'Get "Title"
Cells(4 + n + (k * 32), 4) = Strings.Left(strValue, Len(strValue) - 2)

Cells(4 + n + (k * 32), 5) = objIE.document.getElementsByClassName("itemTitle")(n + 7).innerText 'Get "Date & Time"

strValue = objIE.document.getElementsByClassName("count mylist")(n - 1).innerText 'Get "MyList"
Cells(4 + n + (k * 32), 6) = Mid(strValue, 3)

strValue = objIE.document.getElementsByClassName("count view")(n - 1).innerText 'Get "PlayMovie"
Cells(4 + n + (k * 32), 7) = Mid(strValue, 3)

strValue = objIE.document.getElementsByClassName("count comment")(n - 1).innerText 'Get "Comment"
Cells(4 + n + (k * 32), 8) = Mid(strValue, 3)

strValue = objIE.document.getElementsByClassName("count ads")(n - 1).innerText 'Get "AD"
Cells(4 + n + (k * 32), 9) = Mid(strValue, 3)

m = "0"

For j = 1 To 33 - n
m = InStrRev(strHtml, "uadWrap", m - 1)
Next j

Cells(4 + n + (k * 32), 13) = Mid(strHtml, m + 68, 30) 'Get "Link"

Next n

'終了判断
If dataQuantity > 0 Then
k = k + 1
URL = Worksheets("Sheet2").Cells(3 + k, 11).Value
objIE.Navigate (URL)

Call WaitFor(5)

'「objIE_Source.txt」にサイトのソースを記録する
Set doc = objIE.document
strHtml = doc.DocumentElement.outerhtml
strHtml = Replace(strHtml, vbLf, vbCrLf)

i = FreeFile
Open TXT For Output As i
Print #i, strHtml
Close #i

'「Notepad」を開いて、サイトのソースを表示する
'ret = Shell("Notepad.Exe " & TXT, vbNormalFocus)

GoTo DataCollection
End If

Close:

objIE.Quit
Set objIE = Nothing

End Sub

'IEを待機する関数
Function IEWait(ByRef objIE As Object)

While (objIE.Busy)
Wend
While (objIE.document.ReadyState <> "complete")
Wend

End Function

'指定した秒だけ停止する関数
Function WaitFor(ByVal second As Integer)

Dim futureTime As Date
futureTime = DateAdd("s", second, Now)

While Now < futureTime
DoEvents
Wend

End Function

Function htmlFileOut(objIE)

Set doc = objIE.document
strHtml = doc.DocumentElement.outerhtml
strHtml = Replace(strHtml, vbLf, vbCrLf)

i = FreeFile
Open TXT For Output As i
Print #i, strHtml
Close #i

'「Notepad」を開いて、サイトのソースを表示する
'ret = Shell("Notepad.Exe " & TXT, vbNormalFocus)

End Function