連続してWEBクエリを実行

質問

VBA初心者です。（作業環境Windows7 64bit　Excel2010）

現在、WEBクエリを使用し、あるホームページより情報を収集する作業を行っているのですが、
WEBクエリをループさせる技術がない為、作業が難航しております。

具体的に行いたい作業としましては、
A列に商品番号を数種類入れておき、VBAにてURLの後ろにその番号を追加、
つなぎ合わせたURLでホームページにアクセス　⇒　情報を収集するというものです。

乏しい知識をフル活用し、ループさせずに情報を収集するところまでは作成できたのですが、
どちら様か、ループさせる方法を教えていただける方がおりましたら、ご指導いただけないでしょうか。

■セルに予め入力する番号例■　
　　　　　A
【1】　131023999
【2】　131022082
【3】　131023869
【4】　131023796
【5】　131044236
※最終的には、一度に100種類のページにアクセスしたいと考えております。

■現在作成しているVBAサンプル■

Sub WEBクエリ実行()

Dim SIC1 As String
Dim SIC2 As String
Dim SIC3 As String

SIC1 = Range("A1").Text
SIC2 = Range("A2").Text
SIC3 = Range("A3").Text

On Error Resume Next

With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.bcn-chubu.jp/search/detailed.php?id=" & SIC1, Destination:=Range("C1"))
.FieldNames = True
.FillAdjacentFormulas = False
.PreserveFormatting = True
.BackgroundQuery = True
.SaveData = True
.AdjustColumnWidth = True
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With

With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.bcn-chubu.jp/search/detailed.php?id=" & SIC2, Destination:=Range("C31"))
.FieldNames = True
.FillAdjacentFormulas = False
.PreserveFormatting = True
.BackgroundQuery = True
.SaveData = True
.AdjustColumnWidth = True
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With

With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.bcn-chubu.jp/search/detailed.php?id=" & SIC3, Destination:=Range("C61"))
.FieldNames = True
.FillAdjacentFormulas = False
.PreserveFormatting = True
.BackgroundQuery = True
.SaveData = True
.AdjustColumnWidth = True
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With

End Sub

ちなみに、WEBクエリで収集した情報は、それぞれ指定のセルにアウトプットさせております。
※30行刻みで情報が書き出されるようになっております。

VBA初心者のため、現在作成しているプログラムが「正しいのか」さえ、判断できていない状況ですが、ご指導いただける方がおりましたら、何卒よろしくお願いいたします。

回答No.1

noname#184106

こんにちわ。
こちらでいけると思います。

Sub WEBクエリ実行()

Dim St As Object
Dim I As Integer

Set St = ActiveSheet

Sheets.Add After:=Sheets(Sheets.Count)
For I = 1 To 5
With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.bcn-chubu.jp/search/detailed.php?id=" & Format(St.Cells(I, 1), "@"), Destination:=Range("C" & (I - 1) * 30 + 1))
.FieldNames = True
.FillAdjacentFormulas = False
.PreserveFormatting = True
.BackgroundQuery = True
.SaveData = True
.AdjustColumnWidth = True
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.Refresh BackgroundQuery:=False
End With
Next I
End Sub