自動Web取込み

質問

例えば、ゆうパック 都道府県別の基本運賃表「http://www.post.japanpost.jp/service/you_pack/charge/ichiran.html」の県名がハイパーリンクになっておりA3からA49にデータが入っているとします。
各県を自動的に開け、運賃「http://www.post.japanpost.jp/service/you_pack/charge/ichiran/01.html」をB53以降に取込みたいと思っております。

Sub sample()

Dim h As Hyperlink
For Each h In ActiveSheet.Hyperlinks
h.Range.Offset(0, 1) = h.Address
Next

Dim i As Long
Dim myAddress As String
For i = 3 To 49
myAddress = Range("B" & i).Value
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & myAddress, Destination:=Range("B53"))

.Name = "01"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next i

End Sub

URL「http://www.post.japanpost.jp/service/you_pack/charge/ichiran/01.html」のコピーされたB4、B5と変化させる方法がうまくいきません。
宜しくお願い致します。

回答No.1

imogasi · ベストアンサー

Sheet1のB3に
http://www.post.japanpost.jp/service/you_pack/charge/ichiran/01.html
を入れる。
下方向に複写する。
ーーー
テストを簡単にするため３－９行を処理してますが、４７都道府県繰り返してください。
MsgBox myAddressとMsgBox dは本筋と関係ないので、そのうち削除しても差し支えない。
MsgBox "aaa"は時間稼ぎをしているつもりだが、検討はずれかもしてない。はずしてやってみてください。
For Each h In ActiveSheet.Hyperlinks・・・の部分は意味が理解できなくて、そのままにしています。
ーーーー
標準モジュールに
Sub test01()
Dim h As Hyperlink
For Each h In ActiveSheet.Hyperlinks
MsgBox h.Address
h.Range.Offset(0, 1) = h.Address
Next
'--
Dim i As Long
Dim myAddress As String
d = 53
For i = 3 To 9
MsgBox d
myAddress = Range("B" & i).Value
MsgBox myAddress
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & myAddress, Destination:=Range("B" & d + 1))

.Name = "01"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "1"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
MsgBox "aaa"
'--
d = Range("B65536").End(xlUp).Row
Next i
End Sub
ーー
これを実行すると、５３行目から、北海道、青森・・・福島までの表（For　Nextを９で止めているため途中まで）がコピーされました。
やってみてください。
.Refresh BackgroundQuery:=False辺りが怪しいのですが、WEB上に記事があって、IE履歴、一時ファイルを削除してやりました。ここでトラぶったら
Googleで「Refresh BackgroundQuery:=False」で照会のこと。記事があり参考にすること。
ーー
結局　d = Range("B65536").End(xlUp).RowでDestinationを変化させられなかったための質問かな？

お礼

大変失礼を致しました。
空白行が入ってもRange("B65536").End(xlUp).Rowにより最終行は拾えておりました。

お世話になり　問題解決です。

補足

回答有難う御座います。
特に問題なくVBA作動致しました。

Web取得先データが空白行付きの場合にうまく拾ってくれません。

取得先データ
111111111111

33333333113333
となっている場合
ｄはどのようにすると良いでしょうか。

再度　お手数をお掛け致します。