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

サイトから拾ったサンプルコードなんですが実行時エラー '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

以上です。

Y.H.

2019/09/19 08:00

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

TanakaHiroaki

2019/09/19 08:13

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

nanalabo

2019/09/19 08:33

> For i = LBound(myH2) To UBound(myH2) エラーはこの行で出てるんですか？エラーコードはそちらになります。

tatsu99

2019/09/19 09:19

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

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

回答1件

ベストアンサー

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

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

VBA
1If h2cnt > 0 Then
2	For i = LBound(myH2) To UBound(myH2)
3		If InStr(myBody(x), myH2(i)) > 0 Then
4			myDic.Add "H2-" & x, myH2(i)
5			GoTo Continue
6		End If
7	Next
8End If