エクセルで土日の出走馬から自分の注目している馬の確認方法(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.1

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: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

'レースデータ移動

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
レースNo = Range(レースNo).Offset(2, 0).Address
Sheets("sagyou").Select
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
----------ここまで---------
このマクロでレース情報を自動で取得できるはずです。
全自動なので終了まで、１～２分ほどかかります。
最後に作業用のシートを削除する警告が出ますが、【削除】をクリックしてください。