プロが教えるわが家の防犯対策術!

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

A 回答 (12件中1~10件)

最終修正


-----------

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
-----------
    • good
    • 0

最終修正の補足


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

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

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

多分これ以上変更する必要はないと思います。
    • good
    • 0
この回答へのお礼

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

お礼日時:2007/01/11 20:05

検証の結果、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更新時に取得しようとするとエラーになるかもしれません。
    • good
    • 0
この回答へのお礼

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

お礼日時:2007/01/10 20:09

修正バージョンを投稿します


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




------------------------
    • good
    • 0

現象確認しました


赤字になっている部分のURL前後の?の削除が必要です。

もう一点

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

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

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

With ActiveSheet.QueryTables.Add(Connection:="URL;

http://www.netkeiba.com", Destination:=Range("b1"))

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

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行になるように変更してください。
    • good
    • 0

再度修正しました、修正箇所は一部分なのですが修正後のマクロを掲載します。


取得するタイミングによっては、うまく取れない場合がありますがこれは掲載先の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
    • good
    • 0
この回答へのお礼

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

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

お礼日時:2007/01/09 19:08

今回のマクロは、新規に作成したものですのす。


1)新しいbookを開いて、[ツール]⇒[マクロ]⇒[マクロ]を開く
2)[マクロ名]に”レース取得”と入力し[作成]をクリック。
3)表示されている
Sub レース取得()

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

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

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

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

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

お礼日時:2007/01/08 22:31

再修正


----------ここから----------
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

----------ここまで----------
    • good
    • 0
この回答へのお礼

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

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

お礼日時:2007/01/08 14:43

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!