[[20260817221434]]　『すこしわかりにくいですが　マクロの質問』（ひろくん）　ページの最後に飛ぶ

『すこしわかりにくいですが　マクロの質問』（ひろくん）

こんばんわ
すこしわかりにくい質問ですが
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 ＞

[[20250101190315]] 『このマクロを修正してほしいです』（ひろ）
（参考リンク） 2026/08/18(火) 08:56:26

■１
前トピ？でも確認しましたが、どこがわかりませんか？

ざっと眺めての感想になりますが

 ・マクロ前シートの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

コメント返信：

[ 一覧(最新更新順) ]

[[20260817221434]] 『すこしわかりにくいですが マクロの質問』（ひろくん） ページの最後に飛ぶ

[[20260817221434]]　『すこしわかりにくいですが　マクロの質問』（ひろくん）　ページの最後に飛ぶ