質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

ただいまの
回答率

87.77%

VBA 実行時エラー '9' が表示されます

解決済

回答 1

投稿

  • 評価
  • クリップ 0
  • VIEW 965

score 6

サイトから拾ったサンプルコードなんですが実行時エラー '9'が表示されます。


▼エラーメッセージ
実行時エラー '9':
インデックスが有効範囲にありません。

For i = LBound(myH2) To UBound(myH2)

全部のコードはわからないんですが、範囲指定が間違っていますか?
ぜひご教授お願いします。


以下、コードになります。


Option Explicit
Dim ws1 As Worksheet

Sub AllProcedures()

Dim KeyWord As String, KeyUrl As String
Set ws1 = Worksheets("キーワード一覧")

KeyWord = InputBox("調査したいキーワードを入力する")

KeyUrl = "https://www.google.co.jp/search?q=" & KeyWord

Call GetGoogleSuggestions(KeyUrl, KeyWord)

ws1.Range("A4").Value = "検索キーワード:" & KeyWord

Dim d As String

KeyWord = Replace(KeyWord, "/", "")
KeyWord = Replace(KeyWord, ":", "")

d = Right(Replace(Date, "/", ""), 6)
ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & d & "_" & KeyWord

End Sub

Sub GetGoogleSuggestions(KeyUrl, KeyWord)
Set ws1 = Worksheets("キーワード一覧")
Dim HttpReq As XMLHTTP60

Set HttpReq = New XMLHTTP60
HttpReq.Open "GET", KeyUrl
HttpReq.send

Do While HttpReq.readyState < 4
DoEvents
Loop

Dim oHtml As New MSHTML.HTMLDocument
Dim objTag As Object
Dim PageTitle As String
Dim ContentsURL As String
Dim Counter As Long

Counter = 1

oHtml.body.innerHTML = HttpReq.responseText

For Each objTag In oHtml.getElementsByTagName("a")

If InStr(objTag.outerHTML, "LC20lb") > 0 Then
PageTitle = objTag.innerText
ContentsURL = objTag

Call GetContentsEachPage(ContentsURL, PageTitle, Counter)
Counter = Counter + 1
End If
Next

Continue:

Set HttpReq = Nothing

End Sub
Sub GetContentsEachPage(ContentsURL As String, PageTitle As String, Counter As Long)

Set ws1 = Worksheets("キーワード一覧")
Dim objTag As Object
Dim i As Long, j As Long, cmax As Long
Dim cmax1 As Long, cmax2 As Long, cmax3 As Long
Dim x As Long, p As Long, a As Long
Dim myH2() As String, myH3() As String, myBody As Variant
Dim Keys As Variant
Dim myDic As Object
Set myDic = CreateObject("Scripting.Dictionary")

i = 0
j = 0

Dim HttpReq As XMLHTTP60
Set HttpReq = New XMLHTTP60
HttpReq.Open "GET", ContentsURL
HttpReq.send

Do While HttpReq.readyState < 4
DoEvents
Loop

Dim oHtml As New MSHTML.HTMLDocument

oHtml.body.innerHTML = HttpReq.responseText

myBody = Split(oHtml.body.outerHTML, vbCrLf)

For Each objTag In oHtml.getElementsByTagName("H2")
ReDim Preserve myH2(i)
myH2(i) = objTag.innerText
i = i + 1
Next

For Each objTag In oHtml.getElementsByTagName("H3")
ReDim Preserve myH3(j)
myH3(j) = objTag.innerText
j = j + 1
Next

For x = LBound(myBody) To UBound(myBody)

If InStr(myBody(x), "H2") > 0 Or InStr(myBody(x), "H3") > 0 Then

For i = LBound(myH2) To UBound(myH2)
If InStr(myBody(x), myH2(i)) > 0 Then
myDic.Add "H2-" & x, myH2(i)
GoTo Continue
End If
Next

For j = LBound(myH3) To UBound(myH3)
If InStr(myBody(x), myH3(j)) > 0 Then
myDic.Add "H3-" & x, myH3(j)
GoTo Continue
End If
Next

Continue:
End If

Next

cmax2 = ws1.Range("C1048576").End(xlUp).Row + 1
cmax3 = ws1.Range("D1048576").End(xlUp).Row + 1

cmax = cmax2

If cmax3 > cmax2 Then
cmax = cmax3
End If

ws1.Range("A" & cmax).Value = Counter

With ws1
.Range("B" & cmax).Value = PageTitle
.Range("B" & cmax).WrapText = False
.Hyperlinks.Add anchor:=.Range("B" & cmax), Address:=ContentsURL
End With

cmax = cmax + 1

For Each Keys In myDic
If Left(Keys, 2) = "H2" Then
ws1.Range("C" & cmax).Value = myDic.Item(Keys)
cmax = cmax + 1
ElseIf Left(Keys, 2) = "H3" Then
ws1.Range("D" & cmax).Value = myDic.Item(Keys)
cmax = cmax + 1
End If
Next

Set HttpReq = Nothing

End Sub


以上です。

  • 気になる質問をクリップする

    クリップした質問は、後からいつでもマイページで確認できます。

    またクリップした質問に回答があった際、通知やメールを受け取ることができます。

    クリップを取り消します

  • 良い質問の評価を上げる

    以下のような質問は評価を上げましょう

    • 質問内容が明確
    • 自分も答えを知りたい
    • 質問者以外のユーザにも役立つ

    評価が高い質問は、TOPページの「注目」タブのフィードに表示されやすくなります。

    質問の評価を上げたことを取り消します

  • 評価を下げられる数の上限に達しました

    評価を下げることができません

    • 1日5回まで評価を下げられます
    • 1日に1ユーザに対して2回まで評価を下げられます

    質問の評価を下げる

    teratailでは下記のような質問を「具体的に困っていることがない質問」、「サイトポリシーに違反する質問」と定義し、推奨していません。

    • プログラミングに関係のない質問
    • やってほしいことだけを記載した丸投げの質問
    • 問題・課題が含まれていない質問
    • 意図的に内容が抹消された質問
    • 過去に投稿した質問と同じ内容の質問
    • 広告と受け取られるような投稿

    評価が下がると、TOPページの「アクティブ」「注目」タブのフィードに表示されにくくなります。

    質問の評価を下げたことを取り消します

    この機能は開放されていません

    評価を下げる条件を満たしてません

    評価を下げる理由を選択してください

    詳細な説明はこちら

    上記に当てはまらず、質問内容が明確になっていない質問には「情報の追加・修正依頼」機能からコメントをしてください。

    質問の評価を下げる機能の利用条件

    この機能を利用するためには、以下の事項を行う必要があります。

質問への追記・修正、ベストアンサー選択の依頼

  • Y.H.

    2019/09/19 17:00

    > For i = LBound(myH2) To UBound(myH2)
    エラーはこの行で出てるんですか?

    > 実行時エラー '9':
    > インデックスが有効範囲にありません。
    のダイアログで[デバッグ(D)]を押下するとデバッグできるんで原因はすぐにわかると思うんだけど。。。

    キャンセル

  • TanakaHiroaki

    2019/09/19 17:13

    [デバッグ(D)]を押下した際のエラー箇所は以下行でしょうか。
    Set ws1 = Worksheets("キーワード一覧")

    キャンセル

  • nanalabo

    2019/09/19 17:33

    > For i = LBound(myH2) To UBound(myH2)
    エラーはこの行で出てるんですか?

    エラーコードはそちらになります。

    キャンセル

  • tatsu99

    2019/09/19 18:19

    myH2の要素を設定してるのは
    For Each objTag In oHtml.getElementsByTagName("H2")
    ReDim Preserve myH2(i)
    myH2(i) = objTag.innerText
    i = i + 1
    Next
    ですが、これが、一度も実行されていないと、myH2の要素数が不定なため、
    >実行時エラー '9':
    > インデックスが有効範囲にありません。
    が表示されます。

    キャンセル

回答 1

checkベストアンサー

0

コードをそのまま読むしかないのですが、動的配列(この場合はmyH2)の領域を確保しないままUBound LBoundを使うと「実行時エラー '9'」が出ます。
ではmyH2の領域がどこで確保されるかというと、関数内最初の方のH2タグ分処理しているところです。
ということは「H2タグがない」または「H2タグの探し方がおかしい」のどちらかになると思います。
まずはH2タグのループに入っているかどうかから確認してみてはいかがでしょうか。

もしくはH2タグがない場合でも該当のステップに到達することがある可能性があるのなら「実行時エラー '9'」が発生しないようにガードをする必要があります。
VBAの場合、配列が空か否かを判定する関数は存在しないので、通常であれば判定用関数を作成しON ERRORなんかで切り分けるのですが、今回の場合は幸いにもH2タグのループ処理がありますので、そこで使用している変数iを保持しておけば、要素数がわかります。
例えば変数h2cntなんかに値を持っておき、

If h2cnt > 0 Then
    For i = LBound(myH2) To UBound(myH2)
        If InStr(myBody(x), myH2(i)) > 0 Then
            myDic.Add "H2-" & x, myH2(i)
            GoTo Continue
        End If
    Next
End If


のようにすればガードできるかと。
..

投稿

編集

  • 回答の評価を上げる

    以下のような回答は評価を上げましょう

    • 正しい回答
    • わかりやすい回答
    • ためになる回答

    評価が高い回答ほどページの上位に表示されます。

  • 回答の評価を下げる

    下記のような回答は推奨されていません。

    • 間違っている回答
    • 質問の回答になっていない投稿
    • スパムや攻撃的な表現を用いた投稿

    評価を下げる際はその理由を明確に伝え、適切な回答に修正してもらいましょう。

  • 2019/09/19 18:04

    こちら検索ワードを数字にするとエラーが発生し、英語もしくはひらがな、カナの場合はエラーが出ました。
    コードがそもそもおかしいのかもしれません。。。

    キャンセル

  • 2019/09/19 18:20

    やっと全文登録できた。。。

    参考にしているコードはいつ頃のものなんでしょうかね。
    古いものだとgoogleが出力するHTMLが変わっていて対応できていないのかもしれません。
    とりあえず回答後半の対応をすればエラーは回避できると思うのでお試しください。

    キャンセル

  • 2019/09/20 09:19

    コードが古いのかもしれません。
    こちらの方法で取得するのは諦めます…
    ご協力頂きありがとうございました。

    キャンセル

15分調べてもわからないことは、teratailで質問しよう!

  • ただいまの回答率 87.77%
  • 質問をまとめることで、思考を整理して素早く解決
  • テンプレート機能で、簡単に質問をまとめられる

関連した質問

同じタグがついた質問を見る