[[20190826203237]]　『不可思議　マクロ実行後に列が挿入される』（はじめて）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『不可思議　マクロ実行後に列が挿入される』（はじめて）

マクロを同じシートで一度目は普通に実行されるのに
２回目以降に同じマクロを実行すると
a列が一列挿入されてしまいます
なぜでしょうか

＜ 使用 Excel：Excel2010、使用 OS：Windows7 ＞

---

こんばんは　＾＾　
そぉ〜いう内容のマクロなのではないでしょうか。コードをご提示いただくと
多数、アドバイス、回答が多数、有るかもしれません。m(_ _)m

（隠居じーさん） 2019/08/26(月) 20:48

---

過去からの拾い物です
Option Explicit

 Sub 成績土曜日()
  Application.ScreenUpdating = False

    Const csCode As String = "URL;https://umanity.jp/racedata/race_21.php?code=XXXX"
    Dim strURL As String
Dim i As Integer
For i = 1 To Range("g5").Value
strURL = Get開催コード生成(i)
   strURL = Replace(csCode, "XXXX", strURL)
    Set出馬表取得 strURL

    Dim 処理前シート As Worksheet
    Dim 処理後シート As Worksheet
    Dim 元データ As Range
    Application.DisplayAlerts = False
Dim ws As Worksheet
Set ws = ActiveSheet
    Set 処理前シート = ActiveSheet
    Set 処理後シート = Worksheets("テスト")
    Set 元データ = 処理前シート.UsedRange

    Dim 最終行 As Long
    Dim 開始行 As Long
    Dim r As Long
    Dim shp As Shape
Dim 幅  As Boolean
 幅 = Range("A1").ColumnWidth

    開始行 = 元データ(1, 1).Row
    最終行 = 元データ.Rows.Count + 開始行

    'レース名取得
    Dim レース名 As String
    For r = 開始行 To 最終行
        If 元データ(r, 2).Value <> "" Then
            レース名 = 元データ(r, 2).Offset(2, 0)
            Exit For
        End If
    Next r
        '距離

    Dim 距離 As String
    For r = 開始行 To 最終行
        If 元データ(r, 2).Value <> "" Then
            距離 = 元データ(r, 3).Offset(4, -1)
            Exit For
        End If
    Next r

    '馬情報開始行取得
    Dim 馬情報行 As Long
    For r = 開始行 To 最終行
        If 元データ(r, 6) <> "" Then
            馬情報行 = r + 2
            Exit For
        End If
    Next r
    Cells.Replace What:="◆馬場：", Replacement:="", LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Cells.Find(What:="0m サラ", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False, MatchByte:=False, SearchFormat:=False).Activate
    Cells.FindNext(After:=ActiveCell).Activate
    Selection.TextToColumns Destination:=Range("A52"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=" ", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
        1), Array(6, 1)), TrailingMinusNumbers:=True
        Cells.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
    Cells.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
    Cells.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
    Range("A50").Select
    Selection.TextToColumns Destination:=Range("A50"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Range("A51").Select
    Selection.TextToColumns Destination:=Range("A51"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
        ' 追加
    Cells.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.TextToColumns Destination:=Range("AB52"), DataType:=xlFixedWidth _
        , FieldInfo:=Array(Array(0, 1), Array(11, 1), Array(34, 1), Array(37, 1), Array(44, 1) _
        ), TrailingMinusNumbers:=True
    ' 追加　２

Dim variable As Variant
Dim variable1 As Variant
Dim variable2 As Variant
Dim c As Range

Set c = Range("A1:A200").Find("開催スケジュール", LookAt:=xlPart)
If Not c Is Nothing Then
variable = Cells(c.Row + 8, c.Column).Value
variable1 = Cells(c.Row + 8, c.Column + 1).Value
variable2 = Cells(c.Row + 8, c.Column + 2).Value
End If

    'レース内容取得と書き出し
    Dim 日付, 着, 馬名, 性齢毛色, 斤量, 調教師, 父馬名, 母馬名, 負担重量, 所属, 戦績, 収得賞金, レース番号, 場, レース名2

    Dim cnt As Long
    cnt = 1
    For r = 馬情報行 To 最終行
        If 元データ(r, 6) <> "" Then

            cnt = cnt + 1 'カウンタ
    If ActiveSheet.Cells(r, 1).Value Like "開催スケジュール" Then
'データ取得1
日付 = ActiveSheet.Cells(r, 2).Value

End If

            'データ取得
            日付 = Range("A50").Value
            場 = Range("B50").Value
            レース番号 = Range("A51").Value
            レース名2 = Range("B51").Value
            性齢毛色 = 元データ(r, 6).Value
            馬名 = 元データ(r, 3).Value
            着 = 元データ(r, 1).Value
            調教師 = 元データ(r, 4).Value
            斤量 = 元データ(r, 5).Value
            母馬名 = 元データ(r, 6).Value
            負担重量 = 元データ(r, 7).Value
            調教師 = 元データ(r, 8).Value
            戦績 = 元データ(r, 10).Value
            収得賞金 = 元データ(r, 11).Value
            父馬名 = 元データ(r, 12).Value
            母馬名 = 元データ(r, 13).Value
            '*******************************
            'この間はご自身で考えてコードを追加してください
            '*******************************

            'データ書き出し
            処理後シート.Cells(cnt, 1) = 日付
            処理後シート.Cells(cnt, 2) = 場
            処理後シート.Cells(cnt, 3) = レース番号
            処理後シート.Cells(cnt, 4) = レース名2
            処理後シート.Cells(cnt, 5) = 着
            処理後シート.Cells(cnt, 6) = 馬名
            処理後シート.Cells(cnt, 7) = 斤量
            処理後シート.Cells(cnt, 8) = 性齢毛色
            処理後シート.Cells(cnt, 9) = 負担重量
            処理後シート.Cells(cnt, 10) = 調教師
            処理後シート.Cells(cnt, 11) = 戦績
            処理後シート.Cells(cnt, 12) = 収得賞金
            処理後シート.Cells(cnt, 13) = 父馬名
            処理後シート.Cells(cnt, 14) = 母馬名
            処理後シート.Cells(cnt, 15) = variable
            処理後シート.Cells(cnt, 16) = variable1
            処理後シート.Cells(cnt, 17) = variable2

            '元データシート削除
            '*******************************
            'マクロの記録で記録されたコードを追加
            '*******************************

        End If
    Next r
Cells.UseStandardWidth = 幅
    '*****
    Sheets("テスト").Select
         Range("A7:A27").Select
    Selection.TextToColumns Destination:=Range("A7"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=True, OtherChar:= _
        ")", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
'Call 数字だけ削除
    Columns("A:A").Select
    Selection.Replace What:="（*", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
Range("A7:P100").Select
    Selection.Copy
    Sheets("成績蓄積").Select
    Range("b1").Select
    Selection.End(xlDown).Offset(1, 0).Select
ActiveSheet.Paste
Sheets("テスト").Select
    Cells.Select
    Range("A5").Activate
    Selection.ClearContents
ws.Select
     Range("A15:Ab800").Select
    Selection.QueryTable.Delete
    Selection.ClearContents
    Range("A1").Select
    Application.CutCopyMode = False
Next
    Sheets("成績蓄積").Select
'Call 文字を消す
    ws.Select
    ActiveWorkbook.Save
'ActiveSheet.Previous.Select
Application.ScreenUpdating = True
    Range("A1").Select
End Sub
Function Get開催コード生成(ByVal i As Integer) As String
    Dim Y As String   '年
    Dim d As String   '日付
    Dim c As String   '回
    Dim a As String   '場所
    Dim t As String   '日目
    Dim r As String   'レース番号

    With ThisWorkbook.ActiveSheet
        Y = Format(.Range("A5").Value, "0000")
        d = Format(.Range("B5").Value, "0000")
        a = Get場所コード(.Range("c5").Value)
        c = Format(.Range("D5").Value, "00")
        t = Format(.Range("E5").Value, "00")
        r = Format(.Range("F5").Value + i - 1, "00")
    End With

    Get開催コード生成 = Y & d & a & c & t & r
End Function
Function Get場所コード(ByVal 場所 As String) As String
    '完成
    Dim s As String

    Select Case 場所
        Case "札幌": s = "01"
        Case "函館": s = "02"
        Case "福島": s = "03"
        Case "新潟": s = "04"
        Case "東京": s = "05"
        Case "中山": s = "06"
        Case "中京": s = "07"
        Case "京都": s = "08"
        Case "阪神": s = "09"
        Case "小倉": s = "10"
    End Select

    Get場所コード = s
End Function

Sub Set出馬表取得(ByVal myURL As String)

    With ActiveSheet.QueryTables.Add(Connection:=myURL, _
        Destination:=Range("$A$15"))
        .Name = ""
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub

なのですが
（はじめて） 2019/08/26(月) 21:08

---

回答ではないですが、とりあえずご自身でステップ実行してみては？

出どころはなんとなく察しがつきますから、怪しいものではないでしょうけど、それでもよくわからないコードを提示して試せっていうのは乱暴だと思います。

（もこな２） 2019/08/26(月) 21:36

---

試してみたのですがわからなくて
もう一度試してみます
（はじめて） 2019/08/26(月) 21:39

---

試してみたのですがどうやらデータの取り込みの時点で列が挿入されるみたいで
構文の
Sub Set出馬表取得(ByVal myURL As String)

    With ActiveSheet.QueryTables.Add(Connection:=myURL, _
        Destination:=Range("$A$15"))
        .Name = ""
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlEntirePage
        .WebFormatting = xlWebFormattingNone
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub

の

      .RefreshStyle = xlInsertDeleteCells
  が怪しいと思うのですが
（はじめて） 2019/08/26(月) 22:08

---

https://docs.microsoft.com/ja-jp/office/vba/api/excel.xlcellinsertionmode
＞＞ .RefreshStyle = xlInsertDeleteCells

  が怪しいと思うのですが
が、当たっていましたら↑urlが参考になるかもしれません。
お詳しい方の回答をお待ちください。　m(_ _)m

（隠居じーさん） 2019/08/26(月) 22:43

---

QueryTables.Addをcsv取り込みのためにしか使ったことないので詳しくないですが、

https://kosapi.com/post-3879/
＞指定されたワークシートで行を追加または削除して、クエリが返すレコードセットの行数を受け取る方法を設定します。
＞XlCellInsertionModeクラスの定数を使用します。

なので、「【列】が挿入」とは関係ないような・・・

（もこな２） 2019/08/27(火) 08:03

---

ありがとうございますいろいろ試しましたが原因がわからなくて・・・・・・・・・
（はじめて） 2019/08/27(火) 17:15

---

 >        .RefreshStyle = xlInsertDeleteCells
 を
         .RefreshStyle = xlOverwriteCells

 というか、予め抽出先をクリアにしておけばいいと思うけど？
（seiya） 2019/08/27(火) 17:15

---

ステップ実行しつつ、元データ.Address がどうなっているか確認してみては？ 処理前シート.UsedRange を代入していますが、空欄だったセルに文字列セットしたせいで、範囲が違っているとかありませんか？
（データが手元にない人にデバッグさせようとしないで）

元データ（言葉なのか変数なのか判りにくい変数名は嫌いです）の問題でなかったとしても、1回目と2回目の違いをステップ実行して探してみてください。
（???） 2019/08/27(火) 17:30

---

seiyaさん
というか、予め抽出先をクリアにしておけばいいと思うけど？
というのはどういう意味でしょうか
（はじめて） 2019/08/27(火) 18:14

---

 そのものズバリですが？

  Destination:=Range("$A$15"))
 でA15からデータが転記されているので、A15からデータのある部分をクリアしてから実行する。

 という意味ですが？

 QeryTableは転記先を指定しても、データがあると避けて次の転記可能な範囲で実行します。
（seiya） 2019/08/27(火) 18:39

---

なるほどではデータのクリアの構文を入れればいいんでしょうか
（はじめて） 2019/08/27(火) 20:31

---

 とにかく、一度手作業でクリアしてからの実行で期待通りになるか確認するのが先だと思いますが？
 それでうまくいったらその次を考えるのが順番です。
 こちらでは、そちらの動作が見えませんから...
（seiya） 2019/08/27(火) 20:43

---

遅くなりました
クリアしてからすれば挿入されませんでした
ありがとうございます
（はじめて） 2019/09/09(月) 22:25

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.