エクセルのwebクリエ、マクロ、VBAのURL入力について

こんにちわ、以前もここで質問させていただいたのですが、未完成なので再度質問させてください。
以前と違い、初日の部分を表を作りそこからとれるようにしました。

一、開催場所別にシートを分けているので、それぞれ会場のシートに１２レース分表示したい(A１セル１レース目、E１セル２レース目...と順に横にずれてほしいです)。

一、開催場所でレースがない場合は、webサイト自体ない(エラーが起きる)のでwebサイトがないエラーが起きた時には、A1セルに本日のレースはありませんと表示したい

一、レース番号は引数取得ではなくループ処理にしたいのですが、For Lng_レース = 1 To 12これをどこに入れればいいか、わかりません。
--------------------------------------------------------------
以前、GooUserラックさんに作っていただいたVBAを自分なりに、模索しながらいじってみたのですが、どうしてもできませんでした。

Sub データ抽出(Day_日付 As Date, Lng_場 As Long, Lng_レース As Long)

Dim Str_アドレス As String
Dim Day_初日 As Date

Day_初日 = Day_日付 - Weekday(Day_日付, vbTuesday) + 1
Str_アドレス = "FINDER;http://app.boatrace.jp/race/01_" & Format(Day_初日, "yyyymmdd")
Str_アドレス = Str_アドレス & ".php?day=" & Format(Day_日付, "yyyymmdd")
Str_アドレス = Str_アドレス & "&jyo=" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "&rno=" & Format(Lng_レース, "00") & "&type=program"
Sheets("作業").Select
Cells.Delete Shift:=xlUp
With ActiveSheet.QueryTables.Add(Connection:=Str_アドレス, Destination:=Range("A1"))
.Name = "Data"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub
--------------------------------------------------------------
を自分なりにアレンジしたデータ
--------------------------------------------------------------
Sub 桐生(Day_日付 As Date, Lng_場 As Long, Lng_初日 As Long)

Dim Str_アドレス As String

For Lng_レース = 1 To 12



Str_アドレス = "FINDER;http://app.boatrace.jp/race/" & Format(Lng_レース, "00")
Str_アドレス = Str_アドレス & "_" & Format(Lng_初日, "yyyymmdd")
Str_アドレス = Str_アドレス & ".php?day=" & Format(Day_日付, "yyyymmdd")
Str_アドレス = Str_アドレス & "&jyo=" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "&rno=" & Format(Lng_レース, "00") & "&type=program"
Sheets("桐生").Select
Cells.Delete Shift:=xlUp
With ActiveSheet.QueryTables.Add(Connection:=Str_アドレス, Destination:=Range("A1"))
.Name = "Data"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next
End Sub

回答よろしくお願いいたします。

質問者からの補足コメント

• 画像再

  
    補足日時：2016/06/03 14:21

No.4 ベストアンサー 回答者： GooUserラック 回答日時： 2016/06/03 15:12

呼び出し方はあっています。

ＵＲＬにもう一か所レース場のコードを入れないといけなかったようです。
こちらに差し換えて下さい
----------------------------------------------------------------------------
Sub データ抽出(Day_初日 As Date, Day_日付 As Date, Lng_場 As Long)

Dim Obj_IE As Object
Dim Str_ソース As String
Dim Str_アドレス As String
Dim Lng_レース As Long

Lng_レース = 1
Str_アドレス = "http://app.boatrace.jp/race/" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "_" & Format(Day_初日, "yyyymmdd")
Str_アドレス = Str_アドレス & ".php?day=" & Format(Day_日付, "yyyymmdd")
Str_アドレス = Str_アドレス & "&jyo=" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "&rno=" & Format(Lng_レース, "00") & "&type=program"

Set Obj_IE = CreateObject("InternetExplorer.Application")
With Obj_IE
.Navigate Str_アドレス
Do While .Busy = True
DoEvents
Loop
Do While .Document.ReadyState <> "complete"
DoEvents
Loop
Str_ソース = .Document.Body.InnerText
.Quit
End With
Set Obj_IE = Nothing

If InStr(Str_ソース, "このページは表示できません") <> 0 Then
MsgBox ("アドレス違い")
Exit Sub
End If

If InStr(Str_ソース, "データが見つかりません") <> 0 Then
MsgBox ("データが見つかりません")
Exit Sub
End If

If Len(Str_ソース) < 1500 Then
MsgBox ("データが有りません")
Exit Sub
End If

Sheets("作業").Select
Cells.Delete Shift:=xlUp
For Lng_レース = 1 To 12
Str_アドレス = "http://app.boatrace.jp/race/" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "_" & Format(Day_初日, "yyyymmdd")
Str_アドレス = Str_アドレス & ".php?day=" & Format(Day_日付, "yyyymmdd")
Str_アドレス = Str_アドレス & "&jyo=" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "&rno=" & Format(Lng_レース, "00") & "&type=program"
Str_アドレス = "FINDER;" & Str_アドレス
With ActiveSheet.QueryTables.Add(Connection:=Str_アドレス, Destination:=Cells(1, Lng_レース * 5 - 4))
.Name = "Data"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next
MsgBox ("終了しました")
End Sub

この回答へのお礼

できましたーーー！！！！
ありがとうございます！！！

お礼日時：2016/06/03 15:22

No.3 回答者： GooUserラック 回答日時： 2016/06/03 13:37

図は良く見えないので、一例として

----------------------------------------------------------------------------
Sub 桐生()
Call データ抽出(#5/24/2016#, #5/29/2016#, 1)
End Sub
----------------------------------------------------------------------------
Sub データ抽出(Day_初日 As Date, Day_日付 As Date, Lng_場 As Long)

Dim Obj_IE As Object
Dim Str_ソース As String
Dim Str_アドレス As String
Dim Lng_レース As Long

Lng_レース = 1
Str_アドレス = "http://app.boatrace.jp/race/01_" & Format(Day_初日, "yyyymmdd")
Str_アドレス = Str_アドレス & ".php?day=" & Format(Day_日付, "yyyymmdd")
Str_アドレス = Str_アドレス & "&jyo=" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "&rno=" & Format(Lng_レース, "00") & "&type=program"

Set Obj_IE = CreateObject("InternetExplorer.Application")
With Obj_IE
.Navigate Str_アドレス
Do While .Busy = True
DoEvents
Loop
Do While .Document.ReadyState <> "complete"
DoEvents
Loop
Str_ソース = .Document.Body.InnerText
.Quit
End With
Set Obj_IE = Nothing
If InStr(Str_ソース, "このページは表示できません") <> 0 Then
MsgBox ("アドレス違い")
Exit Sub
End If
If InStr(Str_ソース, "データが見つかりません") <> 0 Then
MsgBox ("データが見つかりません")
Exit Sub
End If
If Len(Str_ソース) < 1500 Then
MsgBox ("データが有りません")
Exit Sub
End If
Sheets("作業").Select
Cells.Delete Shift:=xlUp
For Lng_レース = 1 To 12
Str_アドレス = "http://app.boatrace.jp/race/01_" & Format(Day_初日, "yyyymmdd")
Str_アドレス = Str_アドレス & ".php?day=" & Format(Day_日付, "yyyymmdd")
Str_アドレス = Str_アドレス & "&jyo=" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "&rno=" & Format(Lng_レース, "00") & "&type=program"
Str_アドレス = "FINDER;" & Str_アドレス
With ActiveSheet.QueryTables.Add(Connection:=Str_アドレス, Destination:=Cells(1, Lng_レース * 5 - 4))
.Name = "Data"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next
MsgBox ("終了しました")
End Sub
----------------------------------------------------------------------------

この回答へのお礼

桐生は本日ないので、戸田で試してみたのですが、アドレス違いと出てくるのは何ででしょうか？

画像を更新したので見ていただけるとありがたいのですが、
Callで呼ぶ際に初日をC3セルから、日付をA3セルから、レース場所をB3セルから呼ぶようにしたいので
Call データ抽出(Range("C3").Value, Range("A3").Value, Range("B3").Value)
こうしたのですがあってますか？

画像見にくかったらもう一度上げます。

お礼日時：2016/06/03 14:30

No.2 回答者： GooUserラック 回答日時： 2016/06/03 12:51

開催日が４日間のものも有るんですか？

火曜日～日曜日開催として作ってしまっています。
①初日は必ず火曜日という訳ではないのですね？
②何か決まりがあるのでしょうか？
特に決まりが無いのならば、初日も入力しないとダメです。

この回答へのお礼

はい、４日間しかないものもあったり、5、6日あったり、バラバラなのです。
なので１号艇という文字より上を削除などと指定できるのならばうれしいのですが、もし不可能ならあとで自分で調整してみますので、すべてのデータでも構いません。


＞①初日は必ず火曜日という訳ではないのですね？

そうなんです,,,初日は本当に法則がなくバラバラなのです。
なので、
http://app.boatrace.jp/race/monthly/?day=20160603
このサイトの表をダウンロードして、画像でもわかる通りC列に初日を表示するようにしました！
なので(Day_日付 As Date, Lng_場 As Long, Lng_初日 As Long)のLng_初日 As Longを足せばいいかなと思ったのですが、うまくできませんでした。

お礼日時：2016/06/03 13:07

No.1 回答者： GooUserラック 回答日時： 2016/06/03 12:19

前回はとりあえず、インターネット上のデータをシートに張り付けるだけでした。

私は競艇をやらないので、この中でどのデータが欲しいのかが判りません。
１レースあたり４列のデータが張り付いています。１列くらいあけて次のレースを並べれば良いのでしょうか？
また「１号艇」より上は不要だと思いますし、「表の見方について」以下も不要だと思いますので削除してしまった方が良いのでしょうか？

この回答へのお礼

ご回答ありがとうございます、いつもお世話になってます。

＞１レースあたり４列のデータが張り付いています。１列くらいあけて次のレースを並べれば良いのでしょうか？

はい！１列あけていただいたら助かります！

＞また「１号艇」より上は不要だと思いますし、「表の見方について」以下も不要だと思いますので削除してしまった方が良いのでしょうか？

不要です！
しかしここについてなのですが、１号艇より上は初日～最終日が全部で５日間のもあれば、４日間のもあり、その場合、行が変わってしまうのですが、「１号艇より上」を削除などと指定することは可能なのでしょうか？

お礼日時：2016/06/03 12:37