エクセルで土日の出走馬から自分の注目している馬の確認方法(2)

質問

http://oshiete1.goo.ne.jp/qa2454134.html
以前↑ここでこういう質問をしたのですが、NO.4の回答で教えてもらったマクロでエクセルを実行したら去年までは出馬表の馬名を取り込んでいけたのですが、出馬表の馬名が取得できませんでした。
馬名はもう出ているのに、取り込んでいけませんでした。
どうすれば取り込んでいけるようになりますでしょうか？
マクロのどこか1部分を訂正すればできるようになるのでしょうか？
よろしくお願いします。

回答No.11

web2525 · ベストアンサー

最終修正
-----------

Sub レース取得()
Application.ScreenUpdating = False 'マクロ実行非表示
'
'作業用シート作成
'
保存 = ActiveSheet.Name
ActiveSheet.Name = "data"
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "sagyou"
URR = "URL;http://www.netkeiba.com"
'
' レース情報取得 Macro
'
Sheets("sagyou").Select
表番号 = 15
Do
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:=URR, Destination:=Range("b1"))
.WebFormatting = xlWebFormattingNone
.WebTables = 表番号
.Refresh BackgroundQuery:=False
End With
表番号 = 表番号 + 1
If Range("B1").Value = "中央競馬" Then Exit Do
Loop

Columns("B:B").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:=URR, Destination:=Range("b1"))
.WebTables = 表番号
.Refresh BackgroundQuery:=False
End With

Range("B1:" & Range("b1").End(xlToRight).Address).Select
Selection.Copy
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Columns("B:F").Select
Selection.Delete Shift:=xlToLeft

Range("a1").Activate
Do
ActiveCell.Offset(0, 1).Value = ActiveCell.Hyperlinks(1).Address
ActiveCell.Offset(1, 0).Activate
Loop Until ActiveCell.Value = ""

ActiveCell.Offset(1, 0).Offset(-1, 0).Value = "END"
ActiveCell.Offset(1, 0).Offset(-1, 1).Value = "END"

'
' レース取得 Macro
'
開催 = "B1"
Do
Do Until Right(Range("C1").Value, 2) = "日目"
表番号 = 表番号 + 1
Columns("C:L").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:="URL;" & Range(開催).Value, Destination:=Range("c1"))
.WebTables = 表番号
.Refresh BackgroundQuery:=False
End With

Loop

表番号 = 表番号 + 1

Do

Columns("C:P").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:="URL;" & Range(開催).Value, Destination:=Range("c1"))
.WebTables = 表番号
.Refresh BackgroundQuery:=False
End With

If Left(Range("C1").Value, 1) = " " Then
Else
セルNo = 2
Range("a65535").End(xlUp).Select
Do
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Range("C1").Value
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Range("C" & セルNo).Value
セルNo = セルNo + 2
Loop Until Range("C" & セルNo).Value = ""
End If

Range("D2:" & Range("D65535").End(xlUp).Address).Select
Selection.Copy
Range("B65535").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
表番号 = 表番号 + 1
Loop Until Left(Range("C1").Value, 1) = " "
開催 = Range(開催).Offset(1, 0).Address
Columns("C:P").Select
Selection.Delete Shift:=xlToLeft
表番号 = 20
Loop Until Range(開催).Value = "END"
Range("B65535").End(xlUp).Offset(1, 0).Value = "END"

'
'アドレス取得
'
Range("B1").Select
Do
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell = "END"
ActiveCell.Offset(1, 0).Select

Do
ActiveCell.Offset(0, 1).Value = ActiveCell.Hyperlinks(1).Address
ActiveCell.Offset(2, 0).Activate
Loop Until ActiveCell.Value = "END"
ActiveCell.Offset(0, 1).Value = "END"
'
'出馬表取得
'
レースNo = Range(開催).Address
レースNo = Range(レースNo).Offset(1, 1).Address

Do
表No = 25
Do Until Range("D1").Value = "馬名" Or Range("D1").Value = "枠" Or Range("D1") = "着" Or Range("D1").Value = " お気に入り馬出走情報"
表No = 表No + 1
Sheets("sagyou").Select
Columns("D:O").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & Range(レースNo).Value, Destination:=Range _
("D1"))
.WebFormatting = xlWebFormattingNone
.WebTables = 表No
.Refresh BackgroundQuery:=False
End With

If Range("E1").Value = "競馬新聞を見る" Then
レース名 = 表No
End If
Loop
Columns("D:O").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & Range(レースNo).Value, Destination:=Range _
("D1"))
.WebFormatting = xlWebFormattingNone
.WebTables = レース名 & "," & 表No
.Refresh BackgroundQuery:=False
End With
'
'レースデータ移動
'
Range("D1:" & Range("D1").End(xlDown).Address).Select
Selection.Copy
Sheets("data").Select
Range("A65535").End(xlUp).Offset(2, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("sagyou").Select
Range("D1").End(xlDown).Offset(2, 0).Select

If ActiveCell.Value <> " お気に入り馬出走情報" Then
Do Until ActiveCell.Value = "馬名"
ActiveCell.Offset(0, 1).Select
Loop

左上 = ActiveCell.Address

Do Until ActiveCell.Value = "厩舎"
ActiveCell.Offset(0, 1).Select
Loop

右下 = Range(Left(ActiveCell.Address, 2) & "65535").End(xlUp).Address

Range(左上, 右下).Select
Selection.Copy
Sheets("data").Select
Range("A65535").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Else
Sheets("data").Select
Range("A65535").End(xlUp).Offset(1, 0).Value = "取得できませんでした"
End If
Sheets("sagyou").Select
レースNo = Range(レースNo).Offset(2, 0).Address

Loop Until Range(レースNo) = "END"
'
'作業シート削除
'
Sheets("data").Select
Sheets("data").Name = 保存
Sheets("sagyou").Delete
Columns("A:E").Select
Range("A1363").Activate
Columns("A:E").EntireColumn.AutoFit

End Sub
-----------

回答No.12

web2525

最終修正の補足
1.
コピーして貼り付けた時にＵＲＬ部分
URR = "URL;​http://www.netkeiba.com"　　　←この部分
に？マーク等がついている場合は削除してください。
&#8203などとつく場合も同様

2.
" お気に入り馬出走情報"
↑ここに半角スペースを１つ追加してください。
半角スペースは２個必要
２か所あります。

曜日、時間によってＨＰの体裁が変化するため、どの時点でもエラーなしで取得可能なように対応するため、ＨＰ内の表を順に読み込み必要な表を探し出している関係で取得完了まで５分程度（ご利用の環境により変化します）かかります。

多分これ以上変更する必要はないと思います。

お礼

回答ありがとうございました。
スムーズに全レース取得できました。
この度も本当にありがとうございました。
また機会があればよろしくお願いします。

回答No.10

web2525

検証の結果、ＩＥから張り付けた場合エラーになるようなので、一部修正してください。

修正１
'作業用シート作成
'
保存 = ActiveSheet.Name
ActiveSheet.Name = "data"
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "sagyou"
URR = "URL;http://www.netkeiba.com"　　←これを追加
'
' レース情報取得 Macro

修正２
With ActiveSheet.QueryTables.Add(Connection:="URL;​http://www.netkeiba.com",​ Destination:=Range("b1"))

この部分の
"URL;​http://www.netkeiba.com"
を
URRに変えてください。
２か所あります。

この修正で問題なく動作すると思います。
ＨＰの体裁が変化しても自動で取得する関係で、完了まで数分かかりますが、取得曜日・開催数に影響されず取得可能となっていると思いますが、ＨＰ更新時に取得しようとするとエラーになるかもしれません。

お礼

回答ありがとうございました。
やってみましたが、バッチリできました。
現在は土日の特別だけ出走馬名が出てるのでそこだけちゃんと出ました。
木曜になって今週土日の分が全部出せるかの確認できるまで一応締め切らないでおこうと思います。
今回も度重なる詳しい回答ありがとうございました。

回答No.9

web2525

修正バージョンを投稿します
------------------------
Sub レース取得()
Application.ScreenUpdating = False 'マクロ実行非表示
'
'作業用シート作成
'
保存 = ActiveSheet.Name
ActiveSheet.Name = "data"
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "sagyou"
'
' レース情報取得 Macro
'
Sheets("sagyou").Select
表番号 = 15
Do
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.netkeiba.com", Destination:=Range("b1"))
.WebFormatting = xlWebFormattingNone
.WebTables = 表番号
.Refresh BackgroundQuery:=False
End With
表番号 = 表番号 + 1
If Range("B1").Value = "中央競馬" Then Exit Do
Loop

Columns("B:B").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.netkeiba.com", Destination:=Range("b1"))
.WebTables = 表番号
.Refresh BackgroundQuery:=False
End With

Range("B1:" & Range("b1").End(xlToRight).Address).Select
Selection.Copy
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
Columns("B:F").Select
Selection.Delete Shift:=xlToLeft

Range("a1").Activate
Do
ActiveCell.Offset(0, 1).Value = ActiveCell.Hyperlinks(1).Address
ActiveCell.Offset(1, 0).Activate
Loop Until ActiveCell.Value = ""

ActiveCell.Offset(1, 0).Offset(-1, 0).Value = "END"
ActiveCell.Offset(1, 0).Offset(-1, 1).Value = "END"

'
' レース取得 Macro
'
開催 = "B1"
Do
Do Until Right(Range("C1").Value, 2) = "日目"
表番号 = 表番号 + 1
Columns("C:L").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:="URL;" & Range(開催).Value, Destination:=Range("c1"))
.WebTables = 表番号
.Refresh BackgroundQuery:=False
End With

Loop

表番号 = 表番号 + 1

Do

Columns("C:P").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:="URL;" & Range(開催).Value, Destination:=Range("c1"))
.WebTables = 表番号
.Refresh BackgroundQuery:=False
End With

If Left(Range("C1").Value, 1) = " " Then
Else
セルNo = 2
Range("a65535").End(xlUp).Select
Do
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Range("C1").Value
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Range("C" & セルNo).Value
セルNo = セルNo + 2
Loop Until Range("C" & セルNo).Value = ""
End If

Range("D2:" & Range("D65535").End(xlUp).Address).Select
Selection.Copy
Range("B65535").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
表番号 = 表番号 + 1
Loop Until Left(Range("C1").Value, 1) = " "
開催 = Range(開催).Offset(1, 0).Address
Columns("C:P").Select
Selection.Delete Shift:=xlToLeft
表番号 = 20
Loop Until Range(開催).Value = "END"
Range("B65535").End(xlUp).Offset(1, 0).Value = "END"

'
'アドレス取得
'
Range("B1").Select
Do
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell = "END"
ActiveCell.Offset(1, 0).Select

Do
ActiveCell.Offset(0, 1).Value = ActiveCell.Hyperlinks(1).Address
ActiveCell.Offset(2, 0).Activate
Loop Until ActiveCell.Value = "END"
ActiveCell.Offset(0, 1).Value = "END"
'
'出馬表取得
'
レースNo = Range(開催).Address
レースNo = Range(レースNo).Offset(1, 1).Address

Do
表No = 25
Do Until Range("D1") = "馬名"
表No = 表No + 1
Sheets("sagyou").Select
Columns("D:O").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & Range(レースNo).Value, Destination:=Range _
("D1"))
.WebFormatting = xlWebFormattingNone
.WebTables = 表No
.Refresh BackgroundQuery:=False
End With

If Range("E1").Value = "競馬新聞を見る" Then
レース名 = 表No
End If
Loop
Columns("D:O").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & Range(レースNo).Value, Destination:=Range _
("D1"))
.WebFormatting = xlWebFormattingNone
.WebTables = レース名 & "," & 表No
.Refresh BackgroundQuery:=False
End With
'
'レースデータ移動
'
Range("D1:" & Range("D1").End(xlDown).Address).Select
Selection.Copy
Sheets("data").Select
Range("A65535").End(xlUp).Offset(2, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("sagyou").Select
Range("D1").End(xlDown).Offset(2, 0).Select

Do Until ActiveCell.Value = "馬名"
ActiveCell.Offset(0, 1).Select
Loop

左上 = ActiveCell.Address

Do Until ActiveCell.Value = "厩舎"
ActiveCell.Offset(0, 1).Select
Loop

右下 = Range(Left(ActiveCell.Address, 2) & "65535").End(xlUp).Address

Range(左上, 右下).Select
Selection.Copy
Sheets("data").Select
Range("A65535").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Sheets("sagyou").Select
レースNo = Range(レースNo).Offset(2, 0).Address

Loop Until Range(レースNo) = "END"
'
'作業シート削除
'
Sheets("data").Select
Sheets("data").Name = 保存
Sheets("sagyou").Delete
Columns("A:E").Select
Range("A1363").Activate
Columns("A:E").EntireColumn.AutoFit

End Sub

------------------------

回答No.8

web2525

現象確認しました
赤字になっている部分のＵＲＬ前後の？の削除が必要です。

もう一点

If Range("D1").Value <> " お気に入り馬出走情報" Then

この部分の＜お気に入り馬出走情報＞の前に半角スペースを１つ追加してください。
" お気に入り馬出走情報"
↑ここには半角スペースが２個必要

ＩＥでこのページを表示した場合体裁が一部変更になるようです。

回答No.7

web2525

With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.netkeiba.com", Destination:=Range("b1"))

No6に余分なコードが入っているので再度回答

回答No.6

web2525

With ActiveSheet.QueryTables.Add(Connection:="URL;?​http://www.netkeiba.com",?​

私の環境ではそのまま張り付けても動きましたので気づきませんでしたが、もしかしてこの部分が２行に分かれていますか？
"URL;?​の？を消し、
Destination:=Range("b1"))の前にカーソルを持っていき","バックスペースで？までを消してください。
With ActiveSheet.QueryTables.Add(Connection:="URL;​http://www.netkeiba.com",​ Destination:=Range("b1"))
この部分が１行になるように変更してください。

回答No.5

web2525

再度修正しました、修正箇所は一部分なのですが修正後のマクロを掲載します。
取得するタイミングによっては、うまく取れない場合がありますがこれは掲載先のＨＰの問題ですので解決不能です。
投稿前に試した時は正常取得できました。

・木曜以前の特別レース登録馬情報、
・木曜以降の登録馬確定、
・レース確定後の着順情報
すべて取得可能のはずです。
---------------------------
Sub レース取得()
Application.ScreenUpdating = False

保存 = ActiveSheet.Name
ActiveSheet.Name = "data"
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "sagyou"
'
' レース情報取得 Macro
'
Sheets("sagyou").Select

With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.netkeiba.com", Destination:=Range("b1"))
.WebTables = "17"
.Refresh BackgroundQuery:=False
End With

Rows("2:5").Select
Selection.Delete Shift:=xlUp
Range("B1").Select
Selection.Copy
Range("A1").Select
ActiveSheet.Paste
Range("C1").Select
Selection.Copy
Range("A2").Select
ActiveSheet.Paste
Range("D1").Select
Selection.Copy
Range("A3").Select
ActiveSheet.Paste
Columns("B:D").Select
Selection.Delete Shift:=xlToLeft
Range("a1").Activate

Do
ActiveCell.Offset(0, 1).Value = ActiveCell.Hyperlinks(1).Address
ActiveCell.Offset(1, 0).Activate
Loop Until ActiveCell.Value = ""

ActiveCell.Offset(1, 0).Offset(-1, 0).Value = "END"
ActiveCell.Offset(1, 0).Offset(-1, 1).Value = "END"

'
' レース取得 Macro
'
開催 = "B1"
Do Until Range(開催).Value = "END"
テーブルNo = 29

Do
Columns("C:E").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:="URL;" & Range(開催).Value, Destination:=Range("c1"))
.WebTables = テーブルNo
.Refresh BackgroundQuery:=False
End With

If Left(Range("C1").Value, 1) = " " Then
Else
セルNo = 2
Range("a65535").End(xlUp).Select
Do
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Range("C1").Value
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Range("C" & セルNo).Value
セルNo = セルNo + 2
Loop Until Range("C" & セルNo).Value = ""
End If

Range("D2:" & Range("D65535").End(xlUp).Address).Select
Selection.Copy
Range("B65535").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
テーブルNo = テーブルNo + 1
Loop Until Left(Range("C1").Value, 1) = " "

開催 = Range(開催).Offset(1, 0).Address
Loop

Columns("C:C").Select
Selection.Delete Shift:=xlToLeft

Range("B1").Select
Do
ActiveCell.Offset(1, 0).Select
Loop Until ActiveCell = "END"
ActiveCell.Offset(1, 0).Select

Do
ActiveCell.Offset(0, 1).Value = ActiveCell.Hyperlinks(1).Address
ActiveCell.Offset(2, 0).Activate

If ActiveCell.Value = "" Then
ActiveCell.Offset(1, 0).Activate
If ActiveCell.Value = "END" Then
Exit Do
End If
End If
Loop Until ActiveCell.Value = ""

' レースデータ取得
レースNo = Range(開催).Offset(1, 1).Address

Do
Sheets("sagyou").Select
Columns("D:O").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & Range(レースNo).Value, Destination:=Range _
("D1"))
.WebFormatting = xlWebFormattingNone
.WebTables = "35"
.Refresh BackgroundQuery:=False
End With

If Range("D1").Value = "想定馬" Then
Columns("D:O").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:="URL;" & Range(レースNo).Value, Destination:=Range("D1"))
.WebFormatting = xlWebFormattingNone
.WebTables = "36"
.Refresh BackgroundQuery:=False
End With
End If

If Range("D1").Value <> " お気に入り馬出走情報" Then

'レースデータ移動

Range(レースNo).Offset(0, -2).Select
Range(ActiveCell.Address, ActiveCell.Offset(1, 1).Address).Select
Selection.Copy
Sheets("data").Select
Range("A65535").End(xlUp).Offset(2, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("sagyou").Select
Range("D1").Select

Do Until ActiveCell.Value = "馬名"
ActiveCell.Offset(0, 1).Select
Loop

左上 = ActiveCell.Address

Do Until ActiveCell.Value = "厩舎"
ActiveCell.Offset(0, 1).Select
Loop

右下 = Range(Left(ActiveCell.Address, 2) & "65535").End(xlUp).Address

Range(左上, 右下).Select
Selection.Copy
Sheets("data").Select
Range("A65535").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If

Sheets("sagyou").Select
レースNo = Range(レースNo).Offset(2, 0).Address
If Range(レースNo).Value = "" And Range(レースNo).Offset(2, 0) = "" And Range(レースNo).Offset(4, 0) = "" Then
Exit Do
End If
Loop

Sheets("data").Select
Sheets("data").Name = 保存
Sheets("sagyou").Delete
Columns("A:E").Select
Range("A1363").Activate
Columns("A:E").EntireColumn.AutoFit

Application.ScreenUpdating = True

End Sub

お礼

回答ありがとうございました。
また同じようにエラーになってしまいました。

With ActiveSheet.QueryTables.Add(Connection:="URL;?http://www.netkeiba.com",? Destination:=Range("b1"))
エラーの後この部分が赤くなっています。
なにか関係あるのでしょうか？

回答No.4

web2525

今回のマクロは、新規に作成したものですのす。
１）新しいbookを開いて、［ツール］⇒［マクロ］⇒［マクロ］を開く
２）［マクロ名］に”レース取得”と入力し［作成］をクリック。
３）表示されている
Sub レース取得()

End Sub
を削除してマクロを貼り付けて保存（［Ｘ］で閉じると自動的に保存されます）、ブックも一旦保存してください、次回からは保存したブックで取得可能になります。
４）実行するときには
ツール］⇒［マクロ］⇒［マクロ］を開き、［レース取得］を選択して、［実行］をクリック。
今回のように３日開催とか、２開場以上開催時には取得完了までス分かかる可能性があります。

今回は、会場や日付などの指定なしですべて取り込む方式になっています（多分３開場以上も自動対応するはずです）。

既存のブックに取り込む際には、マクロを追加した後にシートを新たに追加し、追加したシートを開いた状態で実行してください。
シートを追加していけば、同じブックに何回でも出馬表作成が可能です。

お礼

回答ありがとうございます。

新しいbookを開いて教えてもらった手順でNO.3のマクロを貼り付けてやったのですが、
コンパイルエラー
構文エラー
と出てしまい巻いた。今度の木曜の出馬表が出てからじゃないとダメなんでしょうか？どうすればいいかよろしくお願いします。

回答No.3

web2525

再修正
----------ここから----------
Sub レース取得()
Application.ScreenUpdating = False

保存 = ActiveSheet.Name
ActiveSheet.Name = "data"
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "sagyou"
'
' レース情報取得 Macro
'
Sheets("sagyou").Select

With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.netkeiba.com", Destination:=Range("b1"))
.WebTables = "17"
.Refresh BackgroundQuery:=False
End With

Rows("2:5").Select
Selection.Delete Shift:=xlUp
Range("B1").Select
Selection.Copy
Range("A1").Select
ActiveSheet.Paste
Range("C1").Select
Selection.Copy
Range("A2").Select
ActiveSheet.Paste
Range("D1").Select
Selection.Copy
Range("A3").Select
ActiveSheet.Paste
Columns("B:D").Select
Selection.Delete Shift:=xlToLeft
Range("a1").Activate

Do
ActiveCell.Offset(0, 1).Value = ActiveCell.Hyperlinks(1).Address
ActiveCell.Offset(1, 0).Activate
Loop Until ActiveCell.Value = ""

ActiveCell.Offset(1, 0).Offset(-1, 0).Value = "END"
ActiveCell.Offset(1, 0).Offset(-1, 1).Value = "END"

'
' レース取得 Macro
'
開催 = "B1"
Do Until Range(開催).Value = "END"
テーブルNo = 29

Do
Columns("C:E").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:="URL;" & Range(開催).Value, Destination:=Range("c1"))
.WebTables = テーブルNo
.Refresh BackgroundQuery:=False
End With

If Left(Range("C1").Value, 1) = " " Then
Else
セルNo = 2
Range("a65535").End(xlUp).Select
Do
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Range("C1").Value
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Range("C" & セルNo).Value
セルNo = セルNo + 2
Loop Until Range("C" & セルNo).Value = ""
End If

Range("D2:" & Range("D65535").End(xlUp).Address).Select
Selection.Copy
Range("B65535").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
テーブルNo = テーブルNo + 1
Loop Until Left(Range("C1").Value, 1) = " "

開催 = Range(開催).Offset(1, 0).Address
Loop

Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Range("B5").Activate

Do
ActiveCell.Offset(0, 1).Value = ActiveCell.Hyperlinks(1).Address
ActiveCell.Offset(2, 0).Activate

If ActiveCell.Value = "" Then
ActiveCell.Offset(1, 0).Activate
If ActiveCell.Value = "END" Then
Exit Do
End If
End If
Loop Until ActiveCell.Value = ""

' レースデータ取得
レースNo = Range(開催).Offset(1, 1).Address

Do
Sheets("sagyou").Select
Columns("D:O").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & Range(レースNo).Value, Destination:=Range _
("D1"))
.WebFormatting = xlWebFormattingNone
.WebTables = "35"
.Refresh BackgroundQuery:=False
End With

If Range("D1").Value = "想定馬" Then
Columns("D:O").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:="URL;" & Range(レースNo).Value, Destination:=Range("D1"))
.WebFormatting = xlWebFormattingNone
.WebTables = "36"
.Refresh BackgroundQuery:=False
End With
End If

If Range("D1").Value <> " お気に入り馬出走情報" Then

'レースデータ移動

Range(レースNo).Offset(0, -2).Select
Range(ActiveCell.Address, ActiveCell.Offset(1, 1).Address).Select
Selection.Copy
Sheets("data").Select
Range("A65535").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("sagyou").Select
Range("D1").Select

Do Until ActiveCell.Value = "馬名"
ActiveCell.Offset(0, 1).Select
Loop

左上 = ActiveCell.Address

Do Until ActiveCell.Value = "厩舎"
ActiveCell.Offset(0, 1).Select
Loop

右下 = Range(Left(ActiveCell.Address, 2) & "65535").End(xlUp).Address

Range(左上, 右下).Select
Selection.Copy
Sheets("data").Select
Range("A65535").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If

Sheets("sagyou").Select
レースNo = Range(レースNo).Offset(2, 0).Address
If Range(レースNo).Value = "" And Range(レースNo).Offset(2, 0) = "" And Range(レースNo).Offset(4, 0) = "" Then
Exit Do
End If
Loop

Sheets("data").Select
Sheets("data").Name = 保存
Sheets("sagyou").Delete
Columns("A:E").Select
Range("A1363").Activate
Columns("A:E").EntireColumn.AutoFit

Application.ScreenUpdating = True

End Sub

----------ここまで----------

お礼

回答ありがとうございます。
前の質問の時の回答者と同じ方ですね！今回もよろしくお願いします。

回答いただいたマクロはどこに貼り付ければいいのでしょうか？
よろしくお願いします。

回答No.2

web2525

No1のマクロだとレース確定後はエラーになってしまうので、修正しました。
----------ここから----------
Sub レース取得()
Application.ScreenUpdating = False

保存 = ActiveSheet.Name
ActiveSheet.Name = "data"
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "sagyou"
'
' レース情報取得 Macro
'
Sheets("sagyou").Select

With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.netkeiba.com", Destination:=Range("b1"))
.WebTables = "17"
.Refresh BackgroundQuery:=False
End With

Rows("2:5").Select
Selection.Delete Shift:=xlUp
Range("B1").Select
Selection.Copy
Range("A1").Select
ActiveSheet.Paste
Range("C1").Select
Selection.Copy
Range("A2").Select
ActiveSheet.Paste
Range("D1").Select
Selection.Copy
Range("A3").Select
ActiveSheet.Paste
Columns("B:D").Select
Selection.Delete Shift:=xlToLeft
Range("a1").Activate

Do
ActiveCell.Offset(0, 1).Value = ActiveCell.Hyperlinks(1).Address
ActiveCell.Offset(1, 0).Activate
Loop Until ActiveCell.Value = ""

ActiveCell.Offset(1, 0).Offset(-1, 0).Value = "END"
ActiveCell.Offset(1, 0).Offset(-1, 1).Value = "END"

'
' レース取得 Macro
'
開催 = "B1"
Do Until Range(開催).Value = "END"
テーブルNo = 29

Do
Columns("C:E").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:="URL;" & Range(開催).Value, Destination:=Range("c1"))
.WebTables = テーブルNo
.Refresh BackgroundQuery:=False
End With

If Left(Range("C1").Value, 1) = " " Then
Else
セルNo = 2
Range("a65535").End(xlUp).Select
Do
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Range("C1").Value
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Range("C" & セルNo).Value
セルNo = セルNo + 2
Loop Until Range("C" & セルNo).Value = ""
End If

Range("D2:" & Range("D65535").End(xlUp).Address).Select
Selection.Copy
Range("B65535").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
テーブルNo = テーブルNo + 1
Loop Until Left(Range("C1").Value, 1) = " "

開催 = Range(開催).Offset(1, 0).Address
Loop

Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Range("B5").Activate

Do
ActiveCell.Offset(0, 1).Value = ActiveCell.Hyperlinks(1).Address
ActiveCell.Offset(2, 0).Activate

If ActiveCell.Value = "" Then
ActiveCell.Offset(1, 0).Activate
If ActiveCell.Value = "END" Then
Exit Do
End If
End If
Loop Until ActiveCell.Value = ""

' レースデータ取得
レースNo = Range(開催).Offset(1, 1).Address

Do
Sheets("sagyou").Select
Columns("D:M").Select
Selection.Delete Shift:=xlToLeft

With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & Range(レースNo).Value, Destination:=Range _
("D1"))
.WebFormatting = xlWebFormattingNone
.WebTables = "35"
.Refresh BackgroundQuery:=False
End With

If Range("D1").Value = "想定馬" Then
With ActiveSheet.QueryTables.Add(Connection:="URL;" & Range(レースNo).Value, Destination:=Range("D1"))
.WebFormatting = xlWebFormattingNone
.WebTables = "36"
.Refresh BackgroundQuery:=False
End With
End If

If Range("D1").Value <> " お気に入り馬出走情報" Then

'レースデータ移動

Range(レースNo).Offset(0, -2).Select
Range(ActiveCell.Address, ActiveCell.Offset(1, 1).Address).Select
Selection.Copy
Sheets("data").Select
Range("A65535").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("sagyou").Select
Range("D1").Select

Do Until ActiveCell.Value = "馬名"
ActiveCell.Offset(0, 1).Select
Loop

左上 = ActiveCell.Address

Do Until ActiveCell.Value = "厩舎"
ActiveCell.Offset(0, 1).Select
Loop

右下 = Range(Left(ActiveCell.Address, 2) & "65535").End(xlUp).Address

Range(左上, 右下).Select
Selection.Copy
Sheets("data").Select
Range("A65535").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End If

Sheets("sagyou").Select
レースNo = Range(レースNo).Offset(2, 0).Address
If Range(レースNo).Value = "" And Range(レースNo).Offset(2, 0) = "" And Range(レースNo).Offset(4, 0) = "" Then
Exit Do
End If
Loop

Sheets("data").Select
Sheets("data").Name = 保存
Sheets("sagyou").Delete
Columns("A:E").Select
Range("A1363").Activate
Columns("A:E").EntireColumn.AutoFit

Application.ScreenUpdating = True

End Sub

---------ここまで----------