http://oshiete1.goo.ne.jp/qa2454134.html
以前↑ここでこういう質問をしたのですが、NO.4の回答で教えてもらったマクロでエクセルを実行したら去年までは出馬表の馬名を取り込んでいけたのですが、出馬表の馬名が取得できませんでした。
馬名はもう出ているのに、取り込んでいけませんでした。
どうすれば取り込んでいけるようになりますでしょうか?
マクロのどこか1部分を訂正すればできるようになるのでしょうか?
よろしくお願いします。
No.11ベストアンサー
- 回答日時:
最終修正
-----------
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
- 回答日時:
最終修正の補足
1.
コピーして貼り付けた時にURL部分
URR = "URL;http://www.netkeiba.com" ←この部分
に?マーク等がついている場合は削除してください。
​などとつく場合も同様
2.
" お気に入り馬出走情報"
↑ここに半角スペースを1つ追加してください。
半角スペースは2個必要
2か所あります。
曜日、時間によってHPの体裁が変化するため、どの時点でもエラーなしで取得可能なように対応するため、HP内の表を順に読み込み必要な表を探し出している関係で取得完了まで5分程度(ご利用の環境により変化します)かかります。
多分これ以上変更する必要はないと思います。
回答ありがとうございました。
スムーズに全レース取得できました。
この度も本当にありがとうございました。
また機会があればよろしくお願いします。
No.10
- 回答日時:
検証の結果、IEから張り付けた場合エラーになるようなので、一部修正してください。
修正1
'作業用シート作成
'
保存 = ActiveSheet.Name
ActiveSheet.Name = "data"
Sheets.Add After:=ActiveSheet
ActiveSheet.Name = "sagyou"
URR = "URL;http://www.netkeiba.com" ←これを追加
'
' レース情報取得 Macro
修正2
With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.netkeiba.com", Destination:=Range("b1"))
この部分の
"URL;http://www.netkeiba.com"
を
URRに変えてください。
2か所あります。
この修正で問題なく動作すると思います。
HPの体裁が変化しても自動で取得する関係で、完了まで数分かかりますが、取得曜日・開催数に影響されず取得可能となっていると思いますが、HP更新時に取得しようとするとエラーになるかもしれません。
回答ありがとうございました。
やってみましたが、バッチリできました。
現在は土日の特別だけ出走馬名が出てるのでそこだけちゃんと出ました。
木曜になって今週土日の分が全部出せるかの確認できるまで一応締め切らないでおこうと思います。
今回も度重なる詳しい回答ありがとうございました。
No.9
- 回答日時:
修正バージョンを投稿します
------------------------
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
- 回答日時:
現象確認しました
赤字になっている部分のURL前後の?の削除が必要です。
もう一点
If Range("D1").Value <> " お気に入り馬出走情報" Then
この部分の<お気に入り馬出走情報>の前に半角スペースを1つ追加してください。
" お気に入り馬出走情報"
↑ここには半角スペースが2個必要
IEでこのページを表示した場合体裁が一部変更になるようです。
No.7
- 回答日時:
With ActiveSheet.QueryTables.Add(Connection:="URL;
http://www.netkeiba.com", Destination:=Range("b1"))No6に余分なコードが入っているので再度回答
No.6
- 回答日時:
With ActiveSheet.QueryTables.Add(Connection:="URL;?
http://www.netkeiba.com",?私の環境ではそのまま張り付けても動きましたので気づきませんでしたが、もしかしてこの部分が2行に分かれていますか?
"URL;?の?を消し、
Destination:=Range("b1"))の前にカーソルを持っていき","バックスペースで?までを消してください。
With ActiveSheet.QueryTables.Add(Connection:="URL;http://www.netkeiba.com", Destination:=Range("b1"))
この部分が1行になるように変更してください。
No.5
- 回答日時:
再度修正しました、修正箇所は一部分なのですが修正後のマクロを掲載します。
取得するタイミングによっては、うまく取れない場合がありますがこれは掲載先のHPの問題ですので解決不能です。
投稿前に試した時は正常取得できました。
・木曜以前の特別レース登録馬情報、
・木曜以降の登録馬確定、
・レース確定後の着順情報
すべて取得可能のはずです。
---------------------------
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
- 回答日時:
今回のマクロは、新規に作成したものですのす。
1)新しいbookを開いて、[ツール]⇒[マクロ]⇒[マクロ]を開く
2)[マクロ名]に”レース取得”と入力し[作成]をクリック。
3)表示されている
Sub レース取得()
End Sub
を削除してマクロを貼り付けて保存([X]で閉じると自動的に保存されます)、ブックも一旦保存してください、次回からは保存したブックで取得可能になります。
4)実行するときには
ツール]⇒[マクロ]⇒[マクロ]を開き、[レース取得]を選択して、[実行]をクリック。
今回のように3日開催とか、2開場以上開催時には取得完了までス分かかる可能性があります。
今回は、会場や日付などの指定なしですべて取り込む方式になっています(多分3開場以上も自動対応するはずです)。
既存のブックに取り込む際には、マクロを追加した後にシートを新たに追加し、追加したシートを開いた状態で実行してください。
シートを追加していけば、同じブックに何回でも出馬表作成が可能です。
回答ありがとうございます。
新しいbookを開いて教えてもらった手順でNO.3のマクロを貼り付けてやったのですが、
コンパイルエラー
構文エラー
と出てしまい巻いた。今度の木曜の出馬表が出てからじゃないとダメなんでしょうか?どうすればいいかよろしくお願いします。
No.3
- 回答日時:
再修正
----------ここから----------
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
----------ここまで----------
回答ありがとうございます。
前の質問の時の回答者と同じ方ですね!今回もよろしくお願いします。
回答いただいたマクロはどこに貼り付ければいいのでしょうか?
よろしくお願いします。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- 競馬 凱旋門賞での日本馬の活躍を期待します!! 1 2022/10/02 22:21
- 競馬 競馬初心者です 2 2022/05/30 14:38
- 競馬 去勢した競走馬が早く強くなると、馬主はジレンマですか? 種牡馬になれないから 4 2023/04/21 07:24
- その他(悩み相談・人生相談) 頭が良い人は自覚してるの?自分は頭が良いって? 5 2022/05/15 20:33
- マルウェア・コンピュータウイルス 「マカフィー」「ノートン」「無名の会社」のウイルスソフト会社が ポップアップで 4 2023/01/24 05:27
- 歴史学 ディーゼルエンジンの前は馬 9 2023/02/09 00:50
- 競馬 高校生の競馬についてです。そんなにいけないことでしょうか? たまにですが父にお金を渡して馬券を買って 10 2022/09/14 06:59
- 政治 泉代表は競馬場の予想屋並みに競馬に詳しいですが、こんなギャンブル好きの人物が政党の代表で良いですか? 2 2023/02/18 12:48
- 日本語 日本語添削してください2 1 2023/04/09 06:45
- その他(社会・学校・職場) 支店のトップに嫌われています。 私はまだ2年目なのですが、営業で求められている項目の数字を出しても私 4 2022/09/11 10:28
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
なぜ、E(超長距離)はレーティン...
-
必勝法見つけました。
-
JRAの関東→関西の発売順
-
ボートレースは20歳からですよ...
-
地方競馬のメインレースとは?
-
競馬の J G1って何ですか? 普...
-
地方競馬では1万円でレース名...
-
競馬を引退する理由が、もう予...
-
JRAでの高額配当の的中者が...
-
去勢した競走馬が早く強くなる...
-
競馬用語 ただもらいについて
-
三連単はいつ始まったのですか?
-
次週の登録馬(JRA)を確認でき...
-
彼氏が夜遊びで夜中に帰ってく...
-
JRAの引退式について・・・
-
夜遊びをする人
-
ロト7を毎回、10枚買ってれば1...
-
読み方を教えてください。
-
競馬 ①右回りと左回りの競馬場...
-
競馬のコース変更
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
競馬の J G1って何ですか? 普...
-
JRAの過去レースビデオ保存する...
-
ボートレースは20歳からですよ...
-
GI馬ってGIレース出走馬?
-
15:01発走の理由
-
競馬はなぜ一日12レースなん...
-
中央競馬の仕組みを初心者にも...
-
JRAの1レースの売り上げが見れ...
-
地方競馬のメインレースとは?
-
三連単はいつ始まったのですか?
-
JRAでの高額配当の的中者が...
-
競馬用語 ただもらいについて
-
必勝法見つけました。
-
日本で最大のレースは何?
-
圧倒的1番人気馬がいるレースで...
-
G1とは
-
Win5って出目で取ることはでき...
-
JRA-VANのデータをエクセル上で...
-
年末ジャンボ宝くじ1等7億円...
-
IPATとARS、携帯で得な...
おすすめ情報