『すこしわかりにくいですが マクロの質問』（ひろくん）
こんばんわ
すこしわかりにくい質問ですが
https://sports.yahoo.co.jp/keiba/race/list/26040206
の競走成績・払戻金一覧のページをエクセルに貼り付けて
例
１着馬 ２着馬 ３着馬
ラガリーガ シアルナーレ マハロハ
みたいにしたいのですが
以前以下のマクロをつくっていただいたのですが
Option Explicit
Sub 成績11()
'
' Macro4 Macro
Dim max_row As Long
Dim min_row As Long
'開始行と最終行の行番号取得
min_row = Worksheets("マクロ前").UsedRange.Row
max_row = Worksheets("マクロ前").UsedRange.Rows.Count - min_row - 1
Application.ScreenUpdating = False Dim cnt As Long Dim r As Variant Dim レース番号 As Variant Dim レース名 As Variant Dim 距離1 As Variant Dim 距離2 As Variant Dim 距離3 As Variant Dim 斤量 As Variant Dim 斤量2 As Variant Dim 斤量3 As Variant Dim 騎手1 As Variant Dim 騎手2 As Variant Dim 騎手3 As Variant Dim 馬体重 As Variant Dim 一着 As Variant Dim 二着 As Variant Dim 三着 As Variant Dim 四着 As Variant Dim 五着 As Variant Dim 単勝 As Variant Dim 複勝 As Variant Dim 複勝2着 As Variant Dim 複勝3着 As Variant Dim 性齢 As Variant Dim 日付1 As Variant Dim 日付2 As Variant Dim 場1 As Variant Dim クラス As Variant Dim タイム As Variant Dim shp As Shape Dim MyRNG As Range Dim MyRNG2 As Range
With ActiveSheet
For Each MyRNG In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
If MyRNG.Value Like "*R*" Then
MyRNG.Copy MyRNG.Offset(, 1)
End If
Next MyRNG
End With
cnt = 1
Application.DisplayAlerts = False
Sheets("マクロ前").Select
Cells.Select
Range("B1").Activate
Selection.UnMerge
'
Columns("b:b").Select
Selection.Replace What:="*R", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("B:L").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("A:A").Select
Selection.Replace What:="(混)", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="[指]", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="(特指)", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="(国際)", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="(指)", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="サラ系", Replacement:="サラ系 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="(牝)", Replacement:="牝 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="( 別定 )", Replacement:=" 別定 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="( 馬齢 )", Replacement:=" 馬齢 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="( 定量 )", Replacement:=" 定量", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="(ハンデ)", Replacement:=" ハンデ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="( 別定 )", Replacement:=" 別定 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="芝右", Replacement:="芝右 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="芝左", Replacement:="芝左 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="ダート右", Replacement:="ダート右 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="ダート左", Replacement:="ダート左 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="年", Replacement:="年 ", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A10").Select
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("B:L").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlToLeft
Columns("F:G").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("C:C").Select
Range("C203").Activate
'一時的無効化
'Selection.Replace What:="*(", Replacement:="(", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Selection.Replace What:="(", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
' Selection.Replace What:=")", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
With ActiveSheet
For Each MyRNG2 In .Range("c1", .Cells(.Rows.Count, "c").End(xlUp))
If MyRNG2.Value Like "牝" Then
MyRNG2.Copy MyRNG2.Offset(-1, 3)
End If
Next MyRNG2
End With
Columns("E:E").Select
Range("E42").Activate
Selection.TextToColumns Destination:=Range("E1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Columns("F:G").Select
Range("F54").Activate
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlToLeft
Columns("E:E").Select
Range("E49").Activate
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Range("C155").Activate
Selection.Replace What:="４歳上", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
For r = min_row To max_row
If Worksheets("マクロ前").Cells(r, 1).Value Like "202?年" Then
'データ取得1
日付1 = Worksheets("マクロ前").Cells(r, 2).Value
場1 = Worksheets("マクロ前").Cells(r, 3).Value
End If
If Worksheets("マクロ前").Cells(r, 1).Value Like "*R" Then
'データ取得
レース番号 = Worksheets("マクロ前").Cells(r, 1).Value
レース名 = Worksheets("マクロ前").Cells(r + 2, 1).Value
クラス = Worksheets("マクロ前").Cells(r + 2, 2).Value
距離1 = Worksheets("マクロ前").Cells(r + 2, 3).Value
距離2 = Worksheets("マクロ前").Cells(r, 5).Value
一着 = Worksheets("マクロ前").Cells(r + 3, 4).Value
二着 = Worksheets("マクロ前").Cells(r + 4, 4).Value
三着 = Worksheets("マクロ前").Cells(r + 5, 4).Value
騎手1 = Worksheets("マクロ前").Cells(r + 5, 7).Value
騎手2 = Worksheets("マクロ前").Cells(r + 6, 7).Value
騎手3 = Worksheets("マクロ前").Cells(r + 7, 7).Value
斤量 = Worksheets("マクロ前").Cells(r + 5, 6).Value
タイム = Worksheets("マクロ前").Cells(r + 5, 9).Value
'着順終了
単勝 = Worksheets("マクロ前").Cells(r + 9, 3).Value
複勝 = Worksheets("マクロ前").Cells(r + 10, 3).Value
複勝2着 = Worksheets("マクロ前").Cells(r + 11, 3).Value
複勝3着 = Worksheets("マクロ前").Cells(r + 12, 3).Value
性齢 = Worksheets("マクロ前").Cells(r + 5, 5).Value
'データ書き出し2
Worksheets("書き出し2").Cells(cnt, 1).Value = 距離1
Worksheets("書き出し2").Cells(cnt, 2).Value = 距離2
Worksheets("書き出し2").Cells(cnt, 3).Value = 一着
Worksheets("書き出し2").Cells(cnt, 4).Value = 二着
Worksheets("書き出し2").Cells(cnt, 5).Value = 三着
Worksheets("書き出し2").Cells(cnt, 6).Value = "払戻金"
Worksheets("書き出し2").Cells(cnt, 7).Value = 単勝
Worksheets("書き出し2").Cells(cnt, 8).Value = 複勝
Worksheets("書き出し2").Cells(cnt, 9).Value = 複勝2着
Worksheets("書き出し2").Cells(cnt, 10).Value = 複勝3着
'着順終了
Worksheets("書き出し2").Cells(cnt, 11).Value = 性齢
Worksheets("書き出し2").Cells(cnt, 12).Value = 騎手1
Worksheets("書き出し2").Cells(cnt, 13).Value = 騎手2
Worksheets("書き出し2").Cells(cnt, 14).Value = 騎手3
cnt = cnt + 1
End If
Next r
Sheets("書き出し2").Select
Cells.Select
Selection.Replace What:="円", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="r", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="サラ系", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("C:C").Select
Selection.NumberFormatLocal = "G/標準"
Columns("D:D").Select
Selection.Replace What:="(*)", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("C:C").Select
Selection.Replace What:="r", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("A:A").Select
Selection.Replace What:="（*）", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("c1:K100").Select
Selection.Copy
Sheets("払戻金").Select
Range("i1").Select
Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Columns("q:q").Select
Selection.NumberFormatLocal = "m:ss.0"
Sheets("書き出し2").Select
Cells.Select
Selection.ClearContents
Sheets("マクロ前").Select
Call 図形削除
Range("a1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
古くなり
動かなくて困っています
助けてもらえるとありがたいです
よろしくお願いします
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
ざっと眺めての感想になりますが
・マクロ前シートのA列の置換は、「置換前」「置換後」という配列を用意してループ処理してやればシンプルに記載できそう ・書き出し2シートへの書き出しも、一旦配列にためておいて一気に書き出したほうがシンプルにできそう ・全体的に、いちいちSelectなどをしているのでちゃんと整理をした方が可読性があがりそう
ということが気になりました。
何が動かないのかわかりませんが、まずはコードの整理から着手して、整理が終わってからステップ実行により自己検証されては如何でしょうか。
（もこな２） 2026/08/18(火) 10:22:20
競走成績・払戻金一覧のページをエクセルに貼り付けて ってありますけどページのフォーマットが変わっただけでは？ （ちくわ） 2026/08/18(火) 10:55:58
Sub 整理()
Dim max_row As Long
Dim min_row As Long
Dim cnt As Long
Dim MyRNG As Range
Dim r As Variant 'Long型に修正を推奨
'追加した変数
Dim i As Long
Dim 置換前 As Variant, 置換後 As Variant
Dim 一次貯留(1 To 14) As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet
For Each MyRNG In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
If MyRNG.Value Like "*R*" Then MyRNG.Copy MyRNG.Offset(, 1)
Next MyRNG
End With
With Sheets("マクロ前")
'開始行と最終行の行番号取得
min_row = .UsedRange.Row
max_row = .UsedRange.Rows.Count - min_row - 1
.Cells.UnMerge
.Columns("B:B").Replace What:="*R", Replacement:=""
.Columns("B:L").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
With .Columns("A:A")
置換前 = Array("(混)", "[指]", "〜中略〜", "年")
置換後 = Array("", "", "〜中略〜", "年 ")
For i = LBound(置換前) To UBound(置換前)
.Replace What:=置換前(i), Replacement:=置換後(i)
Next
.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, ConsecutiveDelimiter:=True, Tab:=True, Space:=True
End With
.Columns("B:L").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
.Columns("F:G").Insert Shift:=xlToRight
For Each MyRNG In .Range("c1", .Cells(.Rows.Count, "c").End(xlUp))
If MyRNG.Value Like "牝" Then MyRNG.Copy MyRNG.Offset(-1, 3)
Next MyRNG
.Columns("E:E").TextToColumns Destination:=Range("E1"), DataType:=xlDelimited, ConsecutiveDelimiter:=True, Tab:=True, Space:=True
.Columns("F:F").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
.Columns("E:E").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
.Columns("C:C").Replace What:="４歳上", Replacement:=""
cnt = 1
For r = min_row To max_row
'データ取得1は使ってないので廃止
If .Cells(r, 1).Value Like "*R" Then
'データ取得&着順終了
一次貯留(1) = .Cells(r, 1).Value
一次貯留(2) = .Cells(r, 5).Value
一次貯留(3) = .Cells(r + 3, 4).Value
一次貯留(4) = .Cells(r + 4, 4).Value
一次貯留(5) = .Cells(r + 5, 4).Value
一次貯留(6) = "払戻金"
一次貯留(7) = .Cells(r + 9, 3).Value
一次貯留(8) = .Cells(r + 10, 3).Value
一次貯留(9) = .Cells(r + 11, 3).Value
一次貯留(10) = .Cells(r + 12, 3).Value
一次貯留(11) = .Cells(r + 5, 5).Value
一次貯留(12) = .Cells(r + 5, 7).Value
一次貯留(13) = .Cells(r + 6, 7).Value
一次貯留(14) = .Cells(r + 7, 7).Value
'データ書き出し2
Sheets("書き出し2").Cells(cnt, "A").Resize(, 14).Value = 一次貯留
cnt = cnt + 1
End If
Next r
End With
With Sheets("書き出し2")
.Cells.Replace What:="円", Replacement:=""
.Cells.Replace What:="r", Replacement:=""
.Cells.Replace What:="サラ系", Replacement:=""
.Columns("C:C").NumberFormatLocal = "G/標準"
.Columns("D:D").Replace What:="(*)", Replacement:=""
.Columns("C:C").Replace What:="r", Replacement:=""
.Columns("A:A").Replace What:="（*）", Replacement:=""
.Range("c1:K100").Copy Sheets("払戻金").Range("i1").End(xlDown).Offset(1, 0)
.Cells.ClearContents
End With
Sheets("払戻金").Columns("q:q").NumberFormatLocal = "m:ss.0"
Sheets("マクロ前").Select
Call 図形削除 '← 前提が不明なのでそのままにしたが、引数でシートを渡せば上記のSelectは不用
Application.Goto Sheets("マクロ前").Range("a1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
感想として、ちゃんと処理の流れを意識して、インデントの位置などにも気を配ったほうがデバッグ作業がしやすいのではないかと思いました。
（もこな２） 2026/08/18(火) 12:23:21
ブラウザ版 Copilot（https://copilot.microsoft.com）
→ Windows10 でも問題なく使える
Copilot に質問する場合は、
斤量・騎手・タイム・払戻が載っている「result」ページの URL を使ってください。
例：
https://sports.yahoo.co.jp/keiba/race/result/2604020601
list ページには斤量が載っていないため、
どれだけ解析しても目的のデータは取得できません。
Copilot は URL を示せば、
HTML を取得するコード（WinHTTP/XMLHTTP）と
HTML を解析して必要な項目を取り出す VBA を自動で作ってくれます。
（tek） 2026/08/18(火) 18:41:06
0010 Option Explicit
0020 Option Base 1
0030
0040 Sub 整理()
0050 Dim cnt As Long
0060 Dim MyRNG As Range
0070 Dim r As Variant 'Long型に修正を推奨
0080
0090 '追加した変数
0100 Dim i As Long
0110 Dim 置換前 As Variant, 置換後 As Variant
0120 Dim 一時貯留() As Variant
0130 ReDim 一時貯留(1 To 14, 1 To 100) As Variant '後でRedimするから第１要素と第２要素を逆にしておく（最大100行想定）
0140
0150 Application.ScreenUpdating = False
0160 Application.DisplayAlerts = False
0170
0180 With ActiveSheet '←シートを明示的に指定することを推奨
0190 For Each MyRNG In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
0200 If MyRNG.Value Like "*R*" Then MyRNG.Copy MyRNG.Offset(, 1)
0210 Next MyRNG
0220 End With
0230
0240 With Sheets("マクロ前")
0250 .Cells.UnMerge
0260 .Columns("B:B").Replace What:="*R", Replacement:=""
0270 .Columns("B:L").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
0280
0290 Stop 'ブレークポイントの代わり
0300 With .Columns("A:A")
0310 置換前 = Array("(混)", "[指]", "〜中略〜", "年")'★自力でちゃんと修正すること
0320 置換後 = Array("", "", "〜中略〜", "年 ")'★自力でちゃんと修正すること
0330 For i = LBound(置換前) To UBound(置換前)
0340 .Replace What:=置換前(i), Replacement:=置換後(i)
0350 Next
0360
0370 .TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, ConsecutiveDelimiter:=True, Tab:=True, Space:=True
0380 End With
0390
0400 .Columns("B:L").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
0410 .Columns("F:G").Insert Shift:=xlToRight
0420
0430 Stop 'ブレークポイントの代わり
0440 For Each MyRNG In .Range("c1", .Cells(.Rows.Count, "c").End(xlUp))
0450 If MyRNG.Value Like "牝" Then MyRNG.Copy MyRNG.Offset(-1, 3)
0460 Next MyRNG
0470
0480 Stop 'ブレークポイントの代わり
0490 .Columns("E:E").TextToColumns Destination:=Range("E1"), DataType:=xlDelimited, ConsecutiveDelimiter:=True, Tab:=True, Space:=True
0500 .Columns("F:F").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
0510 .Columns("E:E").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
0520 .Columns("C:C").Replace What:="４歳上", Replacement:=""
0530
0540
0550 For r = .UsedRange.Row To .UsedRange.Rows.Count - .UsedRange.Row - 1 '←冗長に思うがとりあえずそのまま
0560 'データ取得1は使ってないので廃止
0570
0580 If .Cells(r, 1).Value Like "*R" Then
0590 cnt = cnt + 1
0600
0610 'データ取得&着順終了
0620 一時貯留(1, cnt) = .Cells(r, 1).Value '距離1
0630 一時貯留(2, cnt) = .Cells(r, 5).Value '距離2
0640 一時貯留(3, cnt) = .Cells(r + 3, 4).Value '一着
0650 一時貯留(4, cnt) = .Cells(r + 4, 4).Value '二着
0660 一時貯留(5, cnt) = .Cells(r + 5, 4).Value '三着
0670 一時貯留(6, cnt) = "払戻金"
0680 一時貯留(7, cnt) = .Cells(r + 9, 3).Value '単勝
0690 一時貯留(8, cnt) = .Cells(r + 10, 3).Value '複勝
0700 一時貯留(9, cnt) = .Cells(r + 11, 3).Value '複勝2着
0710 一時貯留(10, cnt) = .Cells(r + 12, 3).Value '複勝3着
0720 一時貯留(11, cnt) = .Cells(r + 5, 5).Value '性齢
0730 一時貯留(12, cnt) = .Cells(r + 5, 7).Value '騎手1
0740 一時貯留(13, cnt) = .Cells(r + 6, 7).Value '騎手2
0750 一時貯留(14, cnt) = .Cells(r + 7, 7).Value '騎手3
0760 Stop 'ブレークポイントの代わり
0770 End If
0780 Next r
0790 End With
0800
0810 If cnt = 0 Then
0820 MsgBox "データなし"
0830 Else
0840 ReDim Preserve 一時貯留(1 To 14, 1 To cnt) '←ここで不用な"行"をカット（この時点では第２要素）
0850 With Sheets("書き出し2")
0860 '▼行列を入れ替えて書き出し
0870 .Range("A1").Resize(cnt, 14).Value = WorksheetFunction.Transpose(一時貯留)
0880
0890 .Cells.Replace What:="円", Replacement:=""
0900 .Cells.Replace What:="r", Replacement:=""
0910 .Cells.Replace What:="サラ系", Replacement:=""
0920
0930 .Columns("C:C").NumberFormatLocal = "G/標準"
0940 .Columns("D:D").Replace What:="(*)", Replacement:=""
0950 '.Columns("C:C").Replace What:="r", Replacement:="" '←要らない（0900で処理済だから）
0960 .Columns("A:A").Replace What:="（*）", Replacement:=""
0970
0980 .Range("C1:K" & cnt).Copy Sheets("払戻金").Range("i1").End(xlDown).Offset(1, 0)
0990 .Cells.ClearContents
1000 End With
1010
1020 Sheets("払戻金").Columns("q:q").NumberFormatLocal = "m:ss.0"
1030 Sheets("マクロ前").Select
1040 Call 図形削除 '← 前提が不明なのでそのままにしたが、やりようによっては上記のSelectは不用
1050 Application.Goto Sheets("マクロ前").Range("a1")
1060 End If
1070
1080 Application.DisplayAlerts = True
1090 Application.ScreenUpdating = True
1100 End Sub
（もこな２） 2026/08/18(火) 19:39:40
Copilotに質問することをお勧めします。以下はCopilotに作って貰いました どういう指示文を書けばよろしいでしょうか
（ひろくん） 2026/08/23(日) 22:35:56
「この URL の HTML を取得して、斤量・騎手・タイム・払戻を VBA で取り出す方法を教えてください。
使用 OS は Windows10 です。」
といってました。
とりあえず、urlは先のresult
https://sports.yahoo.co.jp/keiba/race/result/2604020601
を提示、
取り出した値が違っていたら修正依頼。
・例えば斤量にｋｇがついていて要らないのなら、斤量からｋｇを除いて再度作成ください。
・払い戻しで必要ないものあったらワイド以下は不要で再度作成ください。
・払い戻しで金額が違っていたら、複勝11番は210円ですよ。
などなど
Copilotの答えで正常に取り出せたのなら、
他の必要要素（レース名やレース番号（これは取り出すよりRが余計なのでurl末尾の01〜12を使うべきかと思う）なども追加又は指定
全て取り出せたら、
あとはご自身のやって欲しいように依頼 例えば、
シート状への書き出し位置指定し、コードに追加して貰う依頼。
urlをレース番号前までを指定し、01〜12までのループを書いて貰うよう依頼。
（tek） 2026/08/24(月) 11:32:34
VBA エディタ → メニュー［ツール］→［参照設定］
Microsoft HTML Object Library にチェックを入れる
（任意）Microsoft XML, v6.0 にチェックを入れる
Excel なら標準モジュールにコードを書く準備をする
2
URL から HTML を取得するコードを書く
レース結果ページの HTML を文字列として取得します。
これってエクセルでalt+F11のエディタでやればいいですか
（ひろくん） 2026/08/24(月) 23:01:56
Sub GetYahooRaceFull()
Dim url As String
url = "https://sports.yahoo.co.jp/keiba/race/result/2604020601"
Dim http As Object
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", url, False
http.send
Dim html As Object
Set html = CreateObject("htmlfile")
html.body.innerHTML = http.responseText
Dim trs As Object, tr As Object
Dim tds As Object
Dim i As Long
Dim rank As String
' --- 結果格納用 ---
Dim horse(1 To 3) As String
Dim sexWeight(1 To 3) As String
Dim timeVal(1 To 3) As String
Dim jockey(1 To 3) As String
Dim kinryo(1 To 3) As String
Dim odds(1 To 3) As String
Set trs = html.getElementsByTagName("tr")
'===============================
' 1着・2着・3着の解析
'===============================
For Each tr In trs
Set tds = tr.getElementsByTagName("td")
If tds.Length >= 9 Then
rank = Trim(tds(0).innerText)
If rank = "1" Or rank = "2" Or rank = "3" Then
i = CInt(rank)
' 馬名（td(3)）
horse(i) = tds(3).getElementsByTagName("a")(0).innerText
' 性齢・馬体重（td(3) の p）
sexWeight(i) = tds(3).getElementsByTagName("p")(0).innerText
' タイム（td(4) の最初のテキスト）
Dim rawTime As String
rawTime = Trim(tds(4).innerText) ' "2:00.0 -"
timeVal(i) = Split(rawTime, " ")(0)
' 騎手名（td(6)）
jockey(i) = tds(6).getElementsByTagName("a")(0).innerText
' 斤量（td(6) の p）
kinryo(i) = tds(6).getElementsByTagName("p")(0).innerText
' 人気（td(7) の最初のテキスト）
odds(i) = Split(Trim(tds(7).innerText), " ")(0)
End If
End If
Next tr
'===============================
' 払戻テーブル解析
'===============================
Dim refund As Object
Dim tbl As Object, row As Object
Dim rType As String, rNum As String, rPay As String
Set refund = html.getElementsByTagName("table")
Debug.Print "【払戻】"
For Each tbl In refund
If InStr(tbl.innerText, "払戻金") > 0 Then
For Each row In tbl.getElementsByTagName("tr")
Set tds = row.getElementsByTagName("td")
If tds.Length >= 3 Then
rType = Trim(tds(0).innerText)
rNum = Trim(tds(1).innerText)
rPay = Trim(tds(2).innerText)
Debug.Print rType & " : " & rNum & " → " & rPay
End If
Next row
End If
Next tbl
'===============================
' 出力
'===============================
Debug.Print "【1?3着】"
For i = 1 To 3
Debug.Print i & "着"
Debug.Print " 馬名: " & horse(i)
Debug.Print " 性齢・馬体重: " & sexWeight(i)
Debug.Print " タイム: " & timeVal(i)
Debug.Print " 騎手: " & jockey(i)
Debug.Print " 斤量: " & kinryo(i)
Debug.Print " 人気: " & odds(i)
Next i
End Sub
（"?"となっているのは多分"〜"です。）
ヤフー競馬の様式が変った場合、新しいurlおよび元のurlとそのときのVBAを提示すればなんとか修正してくれると思います。ただ、質問自体は難しいかも知れませんね。
（tek） 2026/08/25(火) 12:14:41
私はひろくんさんの質問をみても最終的に何がやりたいか解らなかった
（1着から3着までの馬名だけを取り出せれば良い。コードには変数斤量が定義されているがlistページになく困っているなど）
ので、
人から誹謗されないであろうAIの活用、
さらにレース結果が確定しているのなら、開催コード8桁（YYPPKKDD）入力で自動的に
resultページの情報をシート上に取り込めるようになるため便利かと思い提案しました。
（tek） 2026/08/28(金) 10:33:08
Sub GetSchedule()
Const SCHEDULE = "https://sports.yahoo.co.jp/keiba/schedule/yearly?type=pPP&year=YYYY"
'JRA順ではなくYahoo!順です。新潟 と 中山 が入れ替わっています。
Const VENUES = "札幌 函館 福島 新潟 東京 中山 中京 京都 阪神 小倉"
Dim 開催地 As Long '入力 1 to 10
Dim 年 As String '入力 年4桁
Dim mes As String
Dim ws As Worksheet
Dim rw As Long
Dim url As String
Dim http As Object
Dim svenue As String '開催地
Dim html As Object
Dim tdtag As Object
Dim ptag As Object
Dim atag As Object
Dim shtml As String
Dim chtml
Dim yy As String
Dim placeCode As String
Dim rawDate As String
Dim 開催日 As Date
Dim txt As String
Dim id8 As String
年 = InputBox("取得したい年を4桁で入力", , Format(Now, "yyyy"))
For 開催地 = 1 To UBound(Split(VENUES)) + 1
mes = mes & 開催地 & ":" & Split(VENUES)(開催地 - 1) & " "
Next
開催地 = InputBox("開催地コード 1〜10 を入力 " & mes, , 6)
svenue = Split(VENUES)(開催地 - 1)
url = Replace(SCHEDULE, "YYYY", 年)
url = Replace(url, "pPP", "p" & 開催地)
Set http = CreateObject("MSXML2.XMLHTTP")
http.Open "GET", url, False
http.setRequestHeader "User-Agent", "Mozilla/5.0"
http.send
If http.Status <> 200 Then
MsgBox "通信エラー: " & http.Status
Exit Sub
End If
shtml = http.responseText
' chtml = WorksheetFunction.Transpose(Split(shtml, vbLf)) 'ページ解析用にシート展開
' Range("D1").Resize(UBound(chtml)) = chtml
If Not Evaluate("isref(" & svenue & "!a1)") Then
Set ws = Worksheets.Add
ws.Name = svenue
Else
Set ws = Worksheets(svenue)
ws.Range("A:C").ClearContents
End If
rw = 1
Set html = CreateObject("htmlfile")
html.body.innerHTML = http.responseText
yy = Mid(年, 3) '年の下2桁
placeCode = Format(開催地, "00")
For Each tdtag In html.getElementsByTagName("td")
Set atag = Nothing
Set ptag = Nothing
' 開催日セルだけを対象にする
If InStr(tdtag.className, "hr-tableSchedule__data--date") > 0 Then
rawDate = 年 & "年" & Trim(tdtag.innerText) ' 開催日（例：1月4日（日））
開催日 = CDate(Split(rawDate, "（")(0))
' <p> 内のテキスト／リンクを取得
On Error Resume Next
Set ptag = tdtag.getElementsByTagName("p")(0)
If Not ptag Is Nothing Then
Set atag = ptag.getElementsByTagName("a")(0)
End If
On Error GoTo 0
txt = ""
If Not atag Is Nothing Then
' <a> がある場合：例）<a>1回中山1日</a> listページが作成済み
txt = Trim(atag.innerText)
ElseIf Not ptag Is Nothing Then
' <a> がない場合：例）<p>4回中山1日</p> listページが未作成
txt = Trim(ptag.innerText)
End If
If txt <> "" Then
' 8桁ID生成
id8 = "'" & yy & placeCode & Format(Val(txt), "00") & _
Format(Val(Split(txt, svenue)(1)), "00")
ws.Cells(rw, 1).Resize(, 3).Value = Array(開催日, txt, id8)
rw = rw + 1
End If
End If
Next tdtag
ws.Columns("A:C").EntireColumn.AutoFit
If txt = "" Then
MsgBox "開催年: " & 年 & " または 開催地: " & 開催地 & " が不正でデータがありません"
End If
End Sub
（tek） 2026/08/30(日) 07:12:49
Sub 整理()
Dim max_row As Long
Dim min_row As Long
Dim cnt As Long
Dim MyRNG As Range
Dim r As Variant 'Long型に修正を推奨
'追加した変数
Dim i As Long
Dim 置換前 As Variant, 置換後 As Variant
Dim 一次貯留(1 To 14) As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet
For Each MyRNG In .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
If MyRNG.Value Like "*R*" Then MyRNG.Copy MyRNG.Offset(, 1)
Next MyRNG
End With
With Sheets("マクロ前")
'開始行と最終行の行番号取得
min_row = .UsedRange.Row
max_row = .UsedRange.Rows.Count - min_row - 1
.Cells.UnMerge
.Columns("B:B").Replace What:="*R", Replacement:=""
.Columns("B:L").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
With .Columns("A:A")
置換前 = Array("(混)", "[指]", "〜中略〜", "年")
置換後 = Array("", "", "〜中略〜", "年 ")
For i = LBound(置換前) To UBound(置換前)
.Replace What:=置換前(i), Replacement:=置換後(i)
Next
.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, ConsecutiveDelimiter:=True, Tab:=True, Space:=True
End With
.Columns("B:L").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
.Columns("F:G").Insert Shift:=xlToRight
For Each MyRNG In .Range("c1", .Cells(.Rows.Count, "c").End(xlUp))
If MyRNG.Value Like "牝" Then MyRNG.Copy MyRNG.Offset(-1, 3)
Next MyRNG
.Columns("E:E").TextToColumns Destination:=Range("E1"), DataType:=xlDelimited, ConsecutiveDelimiter:=True, Tab:=True, Space:=True
.Columns("F:F").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
.Columns("E:E").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
.Columns("C:C").Replace What:="４歳上", Replacement:=""
cnt = 1
For r = min_row To max_row
'データ取得1は使ってないので廃止
If .Cells(r, 1).Value Like "*R" Then
'データ取得&着順終了
一次貯留(1) = .Cells(r, 1).Value
一次貯留(2) = .Cells(r, 5).Value
一次貯留(3) = .Cells(r + 3, 4).Value
一次貯留(4) = .Cells(r + 4, 4).Value
一次貯留(5) = .Cells(r + 5, 4).Value
一次貯留(6) = "払戻金"
一次貯留(7) = .Cells(r + 9, 3).Value
一次貯留(8) = .Cells(r + 10, 3).Value
一次貯留(9) = .Cells(r + 11, 3).Value
一次貯留(10) = .Cells(r + 12, 3).Value
一次貯留(11) = .Cells(r + 5, 5).Value
一次貯留(12) = .Cells(r + 5, 7).Value
一次貯留(13) = .Cells(r + 6, 7).Value
一次貯留(14) = .Cells(r + 7, 7).Value
'データ書き出し2
Sheets("書き出し2").Cells(cnt, "A").Resize(, 14).Value = 一次貯留
cnt = cnt + 1
End If
Next r
End With
With Sheets("書き出し2")
.Cells.Replace What:="円", Replacement:=""
.Cells.Replace What:="r", Replacement:=""
.Cells.Replace What:="サラ系", Replacement:=""
.Columns("C:C").NumberFormatLocal = "G/標準"
.Columns("D:D").Replace What:="(*)", Replacement:=""
.Columns("C:C").Replace What:="r", Replacement:=""
.Columns("A:A").Replace What:="（*）", Replacement:=""
.Range("c1:K100").Copy Sheets("払戻金").Range("i1").End(xlDown).Offset(1, 0)
.Cells.ClearContents
End With
Sheets("払戻金").Columns("q:q").NumberFormatLocal = "m:ss.0"
Sheets("マクロ前").Select
Call 図形削除 '← 前提が不明なのでそのままにしたが、引数でシートを渡せば上記のSelectは不用
Application.Goto Sheets("マクロ前").Range("a1").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
を試しましたが何も 書き出し1にも書き出し2にも表示されませんなぜでしょうか
（ひろくん） 2026/09/03(木) 21:04:58
>以前以下のマクロをつくっていただいたのですが 回答者が書いたマクロとはとても思えないです。そのスレッドを教えて下さい。
＞古くなり ＞動かなくて困っています どこがどのように変化したのか説明してください。（説明は質問者がすべき必須事項です） 以前はそのマクロで動作していたのですか？
> 例 > １着馬 ２着馬 ３着馬 > ラガリーガ シアルナーレ マハロハ > みたいにしたいのですが
実際にどのような結果を得たいのかを、省略せずに、 行番号、列番号がわかる表形式で示して下さい。 あとから追加・修正がないよう、よく検討したうえで示して下さい。 （なお、全てのレースでなくて構いません。）
（xyz） 2026/09/03(木) 21:47:24
あと、なんで↓はそのままなんですか？
スペースを区切り文字にして分解するのですから重要な要素かとおもうのですが・・・
置換前 = Array("(混)", "[指]", "〜中略〜", "年")
置換後 = Array("", "", "〜中略〜", "年 ")
（もこな２） 2026/09/04(金) 03:33:54
次回からはSheet1のA2セルに開催IDを入れて
データ - すべて更新をクリックして（またはセルのチェンジイベントで更新させるよう）ください
まだデータの無いレースや開催ID間違いは「次のデータ範囲は更新に失敗しました」と出ますのでキャンセルを押してください。
Sub YahooKeiba_PowerQuery_Setup()
Dim wb As Workbook
Dim wsId As Worksheet, wsDetail As Worksheet, wsPayout As Worksheet, wsTop5 As Worksheet
Dim qText As String
Set wb = ThisWorkbook
Application.ScreenUpdating = False
' -------------------------------------------------------------
' 1. シートの作成と「開催ID」の名前定義テーブルの設定
' -------------------------------------------------------------
Set wsId = wb.Worksheets("Sheet1")
Set wsDetail = Make_Sheet(wb, "レース詳細")
Set wsPayout = Make_Sheet(wb, "払戻")
Set wsTop5 = Make_Sheet(wb, "別表")
wsId.Range("A1:A2").Value = [{"開催ID";"26040206"}] 'IDはサンプル
wb.Queries.FastCombine = True
On Error Resume Next
wsId.ListObjects.Add(xlSrcRange, wsId.Range("A1:A2"), , xlYes).Name = "開催ID"
' -------------------------------------------------------------
' 2. 共通クエリ：「接続のみ」の作成
' -------------------------------------------------------------
qText = "let" & vbCrLf & _
" 開催ID = Excel.CurrentWorkbook(){[Name=""開催ID""]}[Content][開催ID]{0}," & vbCrLf & _
" BaseUrl = ""https://sports.yahoo.co.jp/keiba/race/list/"" & Text.From(開催ID)," & vbCrLf & _
" Source = Web.Contents(BaseUrl)," & vbCrLf & _
" ページオブジェクト = Web.Page(Source)," & vbCrLf & _
" HTMLテキスト = Text.FromBinary(Source, TextEncoding.Utf8)," & vbCrLf & _
" 共通データ = [ PageData = ページオブジェクト, HtmlData = HTMLテキスト ]" & vbCrLf & _
"in" & vbCrLf & _
" 共通データ"
wb.Queries.Add Name:="接続のみ", Formula:=qText
' -------------------------------------------------------------
' 3. クエリ：「レース詳細」の作成とシートへの展開
' -------------------------------------------------------------
qText = "let" & vbCrLf & _
" ソース参照 = 接続のみ[PageData]," & vbCrLf & _
" レース詳細データ = ソース参照{0}[Data]" & vbCrLf & _
"in" & vbCrLf & _
" レース詳細データ"
wb.Queries.Add Name:="レース詳細", Formula:=qText
Call Sheet_Load_Query(wsDetail.Range("A1"), wsDetail.Name)
' -------------------------------------------------------------
' 4. クエリ：「払戻」の作成とシートへの展開
' -------------------------------------------------------------
qText = "let" & vbCrLf & _
" HtmlText = 接続のみ[HtmlData]," & vbCrLf & _
" レース毎に分割 = Text.Split(HtmlText, ""<div class=""""hr-splits"""">"")," & vbCrLf & _
" テーブル化 = Table.FromList(レース毎に分割, Splitter.SplitByNothing(), null, null, ExtraValues.Error)," & vbCrLf & _
" インデックス追加 = Table.AddIndexColumn(テーブル化, ""RaceIndex"", 0, 1, Int64.Type)," & vbCrLf & _
" レースデータのみ = Table.SelectRows(インデックス追加, each ([RaceIndex] > 0))," & vbCrLf & _
" 行ごとに分割 = Table.AddColumn(レースデータのみ, ""カスタム"", each Text.Split([Column1], ""<tr""))," & vbCrLf & _
" 不要な列の削除 = Table.RemoveColumns(行ごとに分割,{""Column1""})," & vbCrLf & _
" 行の展開 = Table.ExpandListColumn(不要な列の削除, ""カスタム"")," & vbCrLf & _
" タグの除去 = Table.AddColumn(行の展開, ""テキスト化"", each Text.Combine(Html.Table([カスタム], {{""Text"", "":root""}})[Text], ""#(lf)""))," & vbCrLf & _
" トリミング = Table.TransformColumns(タグの除去, {{""テキスト化"", Text.Trim, type text}})," & vbCrLf & _
" 列の分割 = Table.SplitColumn(トリミング, ""テキスト化"", Splitter.SplitTextByDelimiter(""#(lf)"", QuoteStyle.Csv), 5)," & vbCrLf & _
" 列名の変更 = Table.RenameColumns(列の分割,{{""テキスト化.1"", ""ダミー""}, {""テキスト化.2"", ""券種""}, {""テキスト化.3"", ""馬番""}, {""テキスト化.4"", ""払戻金""}, {""テキスト化.5"", ""人気""}})," & vbCrLf & _
" 必要な列のみ選択 = Table.SelectColumns(列名の変更,{""RaceIndex"", ""券種"", ""馬番"", ""払戻金"", ""人気""})," & vbCrLf & _
" 払戻行のみ = Table.SelectRows(必要な列のみ選択, each Text.Contains([払戻金], ""円""))," & vbCrLf & _
" 重複行の削除 = Table.Distinct(払戻行のみ)" & vbCrLf & _
"in" & vbCrLf & _
" 重複行の削除"
wb.Queries.Add Name:="払戻", Formula:=qText
Call Sheet_Load_Query(wsPayout.Range("A1"), wsPayout.Name)
' -------------------------------------------------------------
' 5. クエリ：「別表（5着まで着順）」の作成とシートへの展開
' -------------------------------------------------------------
qText = "let" & vbCrLf & _
" HtmlText = 接続のみ[HtmlData]," & vbCrLf & _
" Rows8 = Text.Split(HtmlText, ""<tr class=""""hr-tableValue__row"""">"")," & vbCrLf & _
" Rows8_2 = List.RemoveFirstN(Rows8, 1)," & vbCrLf & _
" Parse8 = List.Transform(Rows8_2, each [" & vbCrLf & _
" 着順 = Text.Trim(Text.BetweenDelimiters(_, ""<td class=""""hr-tableValue__data hr-tableValue__data--number"""">"", ""</td>""))," & vbCrLf & _
" 枠番 = Text.Trim(Text.BetweenDelimiters(_, ""<span class=""""hr-icon__bracketNum hr-icon__bracketNum--"", """"""""))," & vbCrLf & _
" 馬番 = Text.Trim(Text.BetweenDelimiters(_, ""<td class=""""hr-tableValue__data hr-tableValue__data--number"""">"", ""</td>"", 2))," & vbCrLf & _
" 馬名 = Text.Trim(Text.BetweenDelimiters(_, ""data-cl-params=""""_cl_link:horse;"""">"", ""</a>""))," & vbCrLf & _
" タイム = Text.Trim(Text.BetweenDelimiters(_, ""<td class=""""hr-tableValue__data hr-tableValue__data--time"""">"", ""</td>""))," & vbCrLf & _
" 着差 = Text.Trim(Text.BetweenDelimiters(_, ""<td class=""""hr-tableValue__data hr-tableValue__data--info"""">"", ""</td>""))," & vbCrLf & _
" 人気 = Text.Trim(Text.BetweenDelimiters(_, ""<td class=""""hr-tableValue__data hr-tableValue__data--popular"""">"", ""</td>""))," & vbCrLf & _
" オッズ = Text.Trim(Text.BetweenDelimiters(_, ""<td class=""""hr-tableValue__data hr-tableValue__data--odds"""">"", ""</td>""))" & vbCrLf & _
" ])," & vbCrLf & _
" 別表 = Table.FromRecords(Parse8)" & vbCrLf & _
"in" & vbCrLf & _
" 別表"
wb.Queries.Add Name:="別表", Formula:=qText
Call Sheet_Load_Query(wsTop5.Range("A1"), wsTop5.Name)
Application.ScreenUpdating = True
' MsgBox "ヤフー競馬用Power Queryの全自動セットアップが完了しました！", vbInformation
End Sub
' クエリの結果をシート上にListObject（テーブル）として出力する共通パーツ
Private Sub Sheet_Load_Query(TargetRange As Range, QueryName As String)
Dim lo As ListObject
Set lo = TargetRange.Worksheet.ListObjects.Add(0, "OLEDB;Provider=Microsoft.Mashup.OleDb.1;Data Source=$Workbook$;Location=" & QueryName, Destination:=TargetRange)
With lo.QueryTable
.CommandType = xlCmdSql
.CommandText = Array("SELECT * FROM [" & QueryName & "]")
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.Refresh True
End With
End Sub
' ワークシートが無ければ作成
Private Function Make_Sheet(wb As Workbook, shname As String) As Worksheet
Dim sh As Worksheet
On Error Resume Next
Set sh = wb.Worksheets(shname)
If sh Is Nothing Then
Set sh = wb.Worksheets.Add
sh.Name = shname
End If
Set Make_Sheet = sh
End Function
（tek） 2026/09/10(木) 22:02:33
GetScheduleはどのように使えばよろしいでしょうか色々聞いてすいません （ひろくん） 2026/09/14(月) 17:54:19
マクロを質問のTOPで提示して、ずっとマクロコードがUPされていますが、
今更、マクロを問いますか？
（ROM） 2026/09/15(火) 06:47:50
回答者が（ひろくん）に質問しているのにこれに答えないならこのページを閉じたらどうですか。
（閲覧者） 2026/09/15(火) 10:14:59
（tek） 2026/09/15(火) 10:59:40
YahooKeiba_PowerQuery_Setupをしてみましたが 開催年と開催場を聞いてきませんでした やり方が悪いのでしょうか （ひろくんん） 2026/09/24(木) 17:45:37
YahooKeiba_PowerQuery_Setupをしてみましたが 開催年と開催場を聞いてきませんでした やり方が悪いのでしょうか
そうです。やり方（どうやったん？！）が悪いんでしょう。
開催年を聞いてくるのって、どしょっぱなの処理なのに、それが実行されていないというのは、（コンパイルエラーとかで）そもそもマクロの実行がされていないとしか思えません。
（通りすがり） 2026/09/25(金) 09:23:38
>>>GetScheduleはどのように使えばよろしいでしょうか色々聞いてすいません >>>（ひろくん） 2026/09/14(月) 17:54:19
>>開催年と開催場を聞いてきますので、それぞれを入力すれば、開催場シート（無ければ自動作成）に 開催日に対応するYahoo!の開催ID8桁が表示されます。
>YahooKeiba_PowerQuery_Setupをしてみましたが 開催年と開催場を聞いてきませんでした
>>新しいBookの標準モジュールに以下のコードをコピペし、1回のみ >>YahooKeiba_PowerQuery_Setupを実行ください
でYahooKeiba_PowerQuery_Setupはなにも聞いてきません。それぞれの使い方書いてあるのでもう一度読み直してください。
（tek） 2026/09/25(金) 12:26:05
あと結果・払い戻しをためていきたいのですがどうすればよろしいでしょうか PowerQueryのことなら別表・払戻・レース詳細として紹介しましたが結果・払い戻しとはどのシートのどのデータをどのような形態で溜めたいのですか。
あるフォルダにBookとして溜めるなら作成したxlsxをコピーして開催IDを変えてから全て更新すれば良いです。あるBookにシートとして溜めるなら シートの移動またはコピー で「コピーを作成する」して保存すればよいです。
あるシートのどこかに保存するなら保存したいシートでCtrl+a（全て選択）してCtrl+ｃでコピー後、保存先の追加したい先頭セルでCtrl+vで貼り付ければよいです。
それぞれVBAで書いてもよいです。
仕様を示してくれれば暇ですのでVBA書くことも可能ですが、以下のようにCopilotに相談することをお勧めします。（Geminiではコードが表示されないことが多かった）
https://www.excel.studio-kazu.jp/kw/20260817221434.html#commentのYahooKeiba_PowerQuery_Setupで作成したBookをC:xxxxxフォルダに都度Bookとして溜めていただきたいのですが、VBAコードを示してください
（tek） 2026/10/02(金) 10:04:48
2． マクロを動かすタイミングについて（どれが良いですか？）
→[B] マクロを実行（ボタン等をクリック）したら、自動的に開催IDを書き換えて、PowerQueryを更新するところからすべて自動で行う
3． 各総合シート（払戻・レース詳細）へのデータの溜め方について
【選択1】 データの並べ方はどちらにしますか？
→ （あ） 1つの表にどんどん下へ追加していく（別の開催IDで更新するたびに、データが下へ下へ縦に繋がっていく形。見出しは一番上に1つだけ）
?【選択2】 表の「形式」はどちらにしますか？
→（え） テーブル機能は使わず、「普通の表（ただの枠線など）」として溜める
【選択3】 見た目のコピー方法はどちらにしますか？
→ （お） 元の表の色や罫線（書式）もそのままコピーする
こちらから
年間払い戻し 年間レース詳細シートはa列からではなくc列からにしていただけますか(できれば列の調整も可能にしていただけたら嬉しいです)
よろしくお願いします
ご不明なことがあれば連絡してください なお明日より出張で 水曜日には帰ります
（ひろくん） 2026/10/04(日) 19:59:18
＞→年間払い戻し 年間レース詳細です
無ければ自動で追加してます。シート順は後で好きなように変えてください
＞→[B] マクロを実行（ボタン等をクリック）したら、自動的に開催IDを書き換えて、PowerQueryを更新するところからすべて自動で行う
テーブル"入力ID一覧"を開催IDセルの右に追加してます。1列目に順次IDを記入していただき、最終セルの値で開催IDを書き換える形にしました
なお、重複取り込み防止や無効ID防止機能を考えましたが各年間シートの手動データ変更に対応出来そうにないので組み入れていません
また、テーブル"入力ID一覧"の2列目・3列目には各開催IDの年間払い戻し・年間レース詳細における集計時での開始セル番号を入れています
＞→ （お） 元の表の色や罫線（書式）もそのままコピーする
データ数偶数の場合は行色は交互に色違いになりますが、開催ID26050302や25100101等同着がありデータ数奇数の場合は
開催IDの先頭行で塗りつぶし無しが続くことになりますがご承知おきください
Sub UpdateAndAggregateKeibaData()
Const 開催ID As String = "開催ID" ' セル名およびテーブル名
Const 入力ID一覧 As String = "入力ID一覧" ' テーブル名
Const 年間払い戻し As String = "年間払い戻し" ' シート名
Const 年間レース詳細 As String = "年間レース詳細" ' シート名
Const cレース詳細 As String = "C" ' 年間レース詳細開始列
Const c払い戻し As String = "C" ' 年間払い戻し開始列
Dim wb As Workbook
Dim wsCurrent As Worksheet
Dim wsRefund As Worksheet
Dim wsRace As Worksheet
Dim tblInput As ListObject
Dim tblRefund As ListObject
Dim tblRace As ListObject
Dim currentID As String
Dim lastRow As Long
Dim targetCellRefund As String
Dim targetCellRace As String
Dim newRow As ListRow
' ブックとシートを変数にセット
Set wb = ThisWorkbook
Set wsCurrent = Application.Range(開催ID).Worksheet
' エラーを無視してテーブル「入力ID一覧」を探す
On Error Resume Next
Set tblInput = wsCurrent.ListObjects(入力ID一覧)
On Error GoTo 0
' もしテーブルが存在しない場合テーブルを作成
If tblInput Is Nothing Then
' シートの右スペースに項目を作成
With wsCurrent.UsedRange
With .Cells(1, .Columns.Count + 3).Resize(, 3)
.Value = Array(入力ID一覧, 年間払い戻し, 年間レース詳細)
Set tblInput = .Worksheet.ListObjects.Add(xlSrcRange, .Cells.Resize(2), , xlYes)
End With
End With
tblInput.Name = 入力ID一覧
tblInput.TableStyle = "TableStyleMedium3" 'テーブルデザインで好みに変更して下さい
' 作成したテーブルの入力セルを選択
With tblInput.DataBodyRange.Cells(1, 1)
Application.Goto .Cells
.NumberFormatLocal = "@"
.HorizontalAlignment = xlRight
End With
' ユーザーに入力を促すメッセージを表示して処理を一度終了する
MsgBox "「" & 入力ID一覧 & "」テーブルを作成しました。最初の開催IDを入力してください。", vbInformation
Exit Sub
End If
' テーブル「入力ID一覧」の最新の値をチェック
With tblInput
lastRow = .DataBodyRange.Rows.Count
currentID = .DataBodyRange.Cells(lastRow, 1).Value
Application.Goto .DataBodyRange.Cells(lastRow, 1)
' 数字8桁であるかを検証（文字数の確認と数値チェック）
If Not currentID Like "########" Then
' 条件を満たさない場合はメッセージを出し終了
MsgBox "数字8桁を入力ください", vbExclamation
Exit Sub
End If
End With
' チェックをクリアした場合、「開催ID」セルに書き込み
With wsCurrent.Range(開催ID)
.NumberFormatLocal = "@" '設定漏れを追加 2000〜2009年対応
.HorizontalAlignment = xlRight
.Value = currentID
End With
' データ出力元のシート名オブジェクトをセット
Set wsRefund = wb.Worksheets("払戻")
Set wsRace = wb.Worksheets("レース詳細")
'動作制限
Application.ScreenUpdating = False ' 画面のちらつきを抑えて処理を高速化
Application.EnableEvents = False 'イベント抑制
Application.Calculation = xlCalculationManual '数式が変更箇所を参照していると凄ーく遅くなる可能性あります
' 新しいデータ有無判定のため、払戻のデータをクリア
On Error Resume Next
wsRefund.ListObjects(1).DataBodyRange.EntireRow.Delete
On Error GoTo 0
' ブック内のすべてのデータ接続（PowerQueryなど）を最新情報に更新
' ※更新完了を待ってから次の処理に進めるため、VBAの制御を同期させます
wb.RefreshAll
DoEvents
' 取り込まれたデータがあるか
Set tblRefund = wsRefund.ListObjects(1)
If tblRefund.DataBodyRange Is Nothing Then
Call 動作制限解除
MsgBox "データは取り込めませんでした 無効なIDの可能性があります"
Exit Sub
End If
' 取り込まれたデータを年間シートに追記
addData wb, 年間払い戻し, c払い戻し, tblRefund, targetCellRefund
Set tblRace = wsRace.ListObjects(1)
addData wb, 年間レース詳細, cレース詳細, tblRace, targetCellRace
' テーブル「入力ID一覧」の2列目・3列目に書き出しセル番号を書き込む
tblInput.DataBodyRange.Cells(lastRow, 2).Resize(, 2).Value = Array(targetCellRefund, targetCellRace)
' テーブル「入力ID一覧」に新しく次の入力用の1行追加し、次の入力セルにカーソル移動
Set newRow = tblInput.ListRows.Add()
Application.Goto newRow.Range.Cells(1, 1)
Call 動作制限解除
' 処理がすべて完璧に完了したことをメッセージで通知します
MsgBox "データの集約が完了しました。次の開催IDを入力してください。", vbInformation
End Sub
Private Sub addData(wb As Workbook, shName As String, c As String, tbl As ListObject, targetCellRefund As String)
' 「shName」シートの存在チェック（なければ作成する）
Dim wsTarget As Worksheet
Dim lastRow As Long
On Error Resume Next
Set wsTarget = wb.Worksheets(shName)
On Error GoTo 0
If wsTarget Is Nothing Then
' シートが存在しない場合は新規に作成し、名前を設定
Set wsTarget = wb.Worksheets.Add
wsTarget.Name = shName
End If
' 開始列（c列）の最終行を調べて、書き込み位置を判定する
With wsTarget
lastRow = .Cells(.Rows.Count, c).End(xlUp).Row
' 開始セル番号を「C & 最終行の1つ下」に設定
targetCellRefund = c & lastRow + 1
End With
If lastRow = 1 Then
' 【最終行が1の場合】テーブル全体のデータをそのままコピーし、テーブル機能解除
tbl.Range.Copy wsTarget.Cells(lastRow, c)
wsTarget.ListObjects(1).Range.EntireColumn.AutoFit
wsTarget.ListObjects(1).Unlist
Else
' 【最終行が1以外の場合】DataBodyRange（データ部分のみ）をコピー
tbl.DataBodyRange.Copy wsTarget.Range(targetCellRefund)
End If
End Sub
Private Sub 動作制限解除()
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
（tek） 2026/10/06(火) 10:08:37
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.