[[20190121213642]]　『３つのマクロを一つにまとめたい』（ひろ）　ページの最後に飛ぶ

『３つのマクロを一つにまとめたい』（ひろ）

いつもお世話になっております
過去に質問してきたネタからも絡むので恐縮ですが
１webデータの取り込み
↓
別シートにコピーして加工
↓
取り込みシートのデータを名前をつけた範囲以外削除
それぞれのマクロを一つにまとめたいのですができますでしょうか
よろしくおねがいします

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

 Sub main()
    macro1
    macro2
    macro3
 End Sub

 m(_ _)m
（隠居じーさん） 2019/01/21(月) 22:01

マクロ名を実行したい順番に並べたらいいのですか

（ひろ） 2019/01/21(月) 22:05

 モジュールが同じかどうか、プライベートかグローバルか、にもよりますが
同一モージュール内であれば
上から順に実行してくれると思います。
パラメータ指定とか、ファンクションで
戻り値を受け取る場合は多少違う場合もありますが
単純に考えれば。。。
具体的な内容がわかりませんので
これくらいしか申し上げられませんです。
m(_ _)m

（隠居じーさん） 2019/01/21(月) 22:14

１
Option Explicit

Sub メイン()

    Const csCode As String = "URL;https://keiba.yahoo.co.jp/race/denma/XXXX/"
    Dim strURL As String

    strURL = Get開催コード生成
    strURL = Replace(csCode, "XXXX", strURL)
    Set出馬表取得 strURL
End Sub

Function Get開催コード生成() As String

    Dim Y As String   '年
    Dim C As String   '回
    Dim A As String   '場所
    Dim T As String   '日目
    Dim R As String   'レース番号

    With ThisWorkbook.Sheets("と")
        Y = Right(.Range("A2").Value, 2)
        A = Get場所コード(.Range("B2").Value)
        C = Format(.Range("C2").Value, "00")
        T = Format(.Range("D2").Value, "00")
        R = Format(.Range("E2").Value, "00")
    End With

    Get開催コード生成 = Y & A & C & T & R
End Function

Function Get場所コード(ByVal 場所 As String) As String

    Dim s As String

    Select Case 場所
        Case "中山": s = "06"
        Case "中京": s = "07"
        Case "京都": s = "08"
    End Select

    Get場所コード = s
End Function

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

    With ThisWorkbook.Sheets("と")
        .Range("$A$4").CurrentRegion.Clear
        With .QueryTables.Add(Connection:=myURL, _
                              Destination:=.Range("$A$4"))
            .Name = ""
            .FieldNames = True
            .RowNumbers = False
            .FillAdjacentFormulas = False
            .PreserveFormatting = True
            .RefreshOnFileOpen = False
            .BackgroundQuery = False
            .RefreshStyle = xlOverwriteCells
            .SavePassword = False
            .SaveData = True
            .AdjustColumnWidth = True
            .RefreshPeriod = 0
            .WebSelectionType = xlSpecifiedTables
            .WebFormatting = xlWebFormattingNone
            .WebTables = "2,3"
            .WebPreFormattedTextToColumns = True
            .WebConsecutiveDelimitersAsOne = True
            .WebSingleBlockTextImport = False
            .WebDisableDateRecognition = False
            .WebDisableRedirections = False
            .Refresh BackgroundQuery:=False
        End With
        .Columns("B").ColumnWidth = .Columns("A").ColumnWidth
    End With
End Sub
と
２
Option Explicit

Sub Sample()

  Dim RowCnt As Long
  Dim GetSh As Worksheet
  Dim PutSh As Worksheet
  Dim PutRow As Long

  Set GetSh = ThisWorkbook.Sheets(1)
  Set PutSh = ThisWorkbook.Sheets(2)

  GetSh.Rows(1).Copy PutSh.Rows(1)
  GetSh.Rows(2).Copy PutSh.Rows(2)
  GetSh.Rows(3).Copy PutSh.Rows(3)
  GetSh.Rows(4).Copy PutSh.Rows(4)
  GetSh.Rows(5).Copy PutSh.Rows(5)
  PutSh.Cells(4, 3).Value = PutSh.Cells(5, 2).Value
  GetSh.Rows(6).Copy PutSh.Rows(5)
  GetSh.Rows(8).Copy PutSh.Rows(6)
  GetSh.Rows(9).Copy PutSh.Rows(7)

  RowCnt = 11
  PutRow = 7
  Do
    If GetSh.Cells(RowCnt, 1).Value = "" Then Exit Do
    PutRow = PutRow + 1
    PutSh.Cells(PutRow, 1).Value = GetSh.Cells(RowCnt, 1).Value
    PutSh.Cells(PutRow, 2).Value = GetSh.Cells(RowCnt, 2).Value
    PutSh.Cells(PutRow, 3).Value = GetSh.Cells(RowCnt, 3).Value
    PutSh.Cells(PutRow, 4).Value = GetSh.Cells(RowCnt, 5).Value
    PutSh.Cells(PutRow, 5).Value = GetSh.Cells(RowCnt, 6).Value
    PutSh.Cells(PutRow, 6).Value = GetSh.Cells(RowCnt + 1, 6).Value
    PutSh.Cells(PutRow, 7).Value = getMyDay(GetSh.Cells(4, 2).Value)
    PutSh.Cells(PutRow, 8).Value = GetSh.Cells(5, 2).Value
    RowCnt = RowCnt + 3
  Loop
End Sub
Function getMyDay(strdate As String) As String
  Dim MyPos As Long
  MyPos = InStr(1, strdate, "（")  '半角「(」ではなく全角「（」かも
  getMyDay = Left(strdate, MyPos - 1)
End Function

と
３
Option Explicit

 Sub 名前定義範囲外削除_行列ver()

    Dim rng As Range
   Dim shp As Shape
    Set rng = Range("取り込み")

For Each shp In ActiveSheet.Shapes
If shp.Name <> "スイッチ" Then shp.Delete
Next

    Range(rng(rng.Count).Offset(1), Cells(Rows.Count, 1)).EntireRow.Delete

    Range(rng(rng.Count).Offset(0, 1), Cells(1, Columns.Count)).EntireColumn.Delete

    If rng(1).Row > 1 Then
        Range(rng(1).Offset(-1), Cells(1, 1)).EntireRow.Delete
    End If

    If rng(1).Column > 1 Then
        Range(rng(1).Offset(0, -1), Cells(1, 1)).EntireColumn.Delete
    End If
For Each shp In ActiveSheet.Shapes
If shp.Name <> "スイッチ" Then shp.Delete
Next

End Sub

の３つをまとめたいです
ほんとは２と３に加工用のシートからデータ蓄積用のシートにコピーするマクロも入れたいのですが・・・
（ひろ） 2019/01/21(月) 23:00

拝見すれば、呼び出しておられるように推察致します。
呼び出す順番はコードをお書きになった方が一番ご存知だと思います。
具体的にどのロシジャーが呼び出せないのでしょうか。
Option Explicit
が複数出現しているので
モジュールが違うのでしょうかね
BOOKが違うとか。
もしそうでしたら
vba Application.Run の使い方
で検索してみて下さい

呼び出し方は様々ですが
上から呼び出した順に実行さると思います。
でわ

（隠居じーさん） 2019/01/21(月) 23:42

 他にもいろいろあるかもしれませんが。
（型定義、参照方法は省略）
簡単サンプル。。。ということで　＾＾；
でわ
 Option Explicit
Sub main()
    Dim tmp
    s1
    s2 "s2"
    tmp = f1

    MsgBox tmp

    tmp = f2("f2")

    MsgBox tmp
End Sub
Sub s1()
    MsgBox "s1"
End Sub
Sub s2(arg1)
    MsgBox arg1
End Sub
Function f1() As String
    f1 = "f1"
End Function
Function f2(arg1) As String
   f2 = arg1 & "f2"
End Function
（隠居じーさん） 2019/01/22(火) 09:11

質問とは関係ないですし、ざーっとしか読んでないので勘違いかもですけど、気になる点として

(1)
「メイン」プロシージャから、「Set出馬表取得」プロシージャの呼び出してるけど、プロシージャを分ける必要性がよくわからないなぁとおもいます。

(2)
「Sample」プロシージャで

  GetSh.Rows(5).Copy PutSh.Rows(5)
  GetSh.Rows(6).Copy PutSh.Rows(5)

ってなってるから、PutSh.Rows(5)は上書きされることになっているので、実は行番号まちがってません？

(3)
「名前定義範囲外削除_行列ver」プロシージャですけど

 For Each shp In ActiveSheet.Shapes
   If shp.Name <> "スイッチ" Then shp.Delete
 Next

なんで↑を2回実行するんですか？

（もこな２） 2019/01/22(火) 11:36

隠居じーさんさん　ありがとうございます
１．２点聞きたいのですが
s1とかs2というのはどういうことでしょうか
またマクロ本体はどこに書けばいいでしょうか
わからないことだらけですいません
（ひろ） 2019/01/22(火) 12:29

下に記述したサブプロシジャー名です
mainを実行すれば
下の4個のプロシージャーが順次実行され
メッセージがポップアップ表示されます。

ｓ1、ｓ2は下の呼び出すプロシジャーの名前です。
名前定義範囲外削除_行列ver
と同じです。
マクロの中身は

Sub s1()

    MsgBox "s1"
    ここ↑ です。

End Sub

（隠居じーさん） 2019/01/22(火) 12:48

編集かぶりましたが、そのまま。

隠居じーさんさんではないですが、オマケ程度にコメントをつけるとこうですかね。

   '***************************
   Sub main()
       Dim tmp

       'Subプロシージャ「s1」を呼び出す
       Call s1

       'Subプロシージャ「s2」に引数「"s2"」を与えて呼び出す
       Call s2("s2")

      '変数「tmp」にFunctionプロシージャ「f1」の返り値を格納して
      'メッセージボックスで表示する
       tmp = f1
       MsgBox tmp

      '変数「tmp」にFunctionプロシージャ「f2」に引数｢"f2"｣を与えた結果の返り値を格納して
      'メッセージボックスで表示する
       tmp = f2("f2")
       MsgBox tmp

   End Sub
   '***************************
   Sub s1()
       MsgBox "s1"
   End Sub
   '***************************
   Sub s2(arg1)
       MsgBox arg1
   End Sub
   '***************************
   Function f1() As String
       f1 = "f1"
   End Function
   '***************************
   Function f2(arg1) As String
      f2 = arg1 & "f2"
   End Function
   '***************************

＞またマクロ本体はどこに書けばいいでしょうか
質問の意図がわからないけど、新規ブックでも開いて、標準モジュールを追加し、まるっと貼り付けたらいいんじゃないですか？

（もこな２） 2019/01/22(火) 12:59

追加で。

ステップ実行すると、実行される部分がハイライトされ、どんな順番で実行されているのか目視できるとおもいますから、まだ試されていなければやってみては如何でしょうか

【ステップ実行】
https://www.239-programing.com/excel-vba/basic/basic023.html
http://plus1excel.web.fc2.com/learning/l301/t405.html
https://asatte.biz/vba-debug-menu/

（もこな２） 2019/01/22(火) 13:35

隠居じーさん
メッセージボックスのところって必要でしょうか
省いても支障がなければ省きたいのですが
（ひろ） 2019/01/22(火) 19:53

やってみました
マクロをまとめて実行するのは
隠居じーさんさんの
Sub main()

    macro1
    macro2
    macro3
 End Sub
でやりましたが
Option Explicit

 Sub 名前定義範囲外削除_行列ver()

    Dim rng As Range
   Dim shp As Shape
    Set rng = Range("取り込み")

For Each shp In ActiveSheet.Shapes
If shp.Name <> "スイッチ" Then shp.Delete
Next

    Range(rng(rng.Count).Offset(1), Cells(Rows.Count, 1)).EntireRow.Delete

    Range(rng(rng.Count).Offset(0, 1), Cells(1, Columns.Count)).EntireColumn.Delete

    If rng(1).Row > 1 Then
        Range(rng(1).Offset(-1), Cells(1, 1)).EntireRow.Delete
    End If

    If rng(1).Column > 1 Then
        Range(rng(1).Offset(0, -1), Cells(1, 1)).EntireColumn.Delete
    End If
For Each shp In ActiveSheet.Shapes
If shp.Name <> "スイッチ" Then shp.Delete
Next

End Sub
で名前のつけた図形も消えてしまうのですが・・・・
（ひろ） 2019/01/22(火) 20:21

これまた隠居じーさんさんではないけど

＞名前のつけた図形も消えてしまうのですが・・・・
確認ですが、スイッチという名前を付けた図形が消えたということでよいのでしょうか？

スイッチという名前以外であれば、削除されるのは正常な動作であるというのは理解してますよね？

もっとも指摘してもガン無視されてるから、私の意見は求めてないのかもしれないが・・
（もこな２） 2019/01/22(火) 20:34

なまえはスイッチにしています
（ひろ） 2019/01/22(火) 21:06

＞＞隠居じーさん
＞＞メッセージボックスのところって必要でしょうか
＞＞省いても支障がなければ省きたいのですが
どうぞ
省いてください。

（隠居じーさん） 2019/01/22(火) 21:25

＞なまえはスイッチにしています
そうなるとわからないですね。
とりあえず、↓を実行してみて、イミディエイトに「【スイッチ】を削除する」って出てこなければ、ちゃんと判定されているとは思いますが。。

    Sub 実験()
        Dim shp As Shape

        For Each shp In ActiveSheet.Shapes
            If shp.Name <> "スイッチ" Then
                Debug.Print "【" & shp.Name & "】を削除する"
                shp.Delete
            End If
        Next

    End Sub

あと、考えられるのは、行（セル範囲）を削除しているから、削除した行に追従してサイズが変わり高さ0の図形になっていて、見えないだけでしたっていうオチはないですかね？

（もこな２） 2019/01/22(火) 22:38

試しましたイミディエイトウィンドウには何も出てきませんでした　
ということは
Option Explicit

 Sub 名前定義範囲外削除_行列ver()

    Dim rng As Range
   Dim shp As Shape
    Set rng = Range("取り込み")

For Each shp In ActiveSheet.Shapes
If shp.Name <> "スイッチ" Then shp.Delete
Next

    Range(rng(rng.Count).Offset(1), Cells(Rows.Count, 1)).EntireRow.Delete

    Range(rng(rng.Count).Offset(0, 1), Cells(1, Columns.Count)).EntireColumn.Delete

    If rng(1).Row > 1 Then
        Range(rng(1).Offset(-1), Cells(1, 1)).EntireRow.Delete
    End If

    If rng(1).Column > 1 Then
        Range(rng(1).Offset(0, -1), Cells(1, 1)).EntireColumn.Delete
    End If
For Each shp In ActiveSheet.Shapes
If shp.Name <> "スイッチ" Then shp.Delete
Next

End Sub

に問題があるんでしょうか
Sub main()

    macro1
    macro2
    macro3
 End Sub
の２までは予定通り動きます
（ひろ） 2019/01/22(火) 23:09

＞試しましたイミディエイトウィンドウには何も出てきませんでした
私が悪いのかなぁ・・・・こちらでテストしてみてください。

    Sub 実験()
        Dim shp As Shape

        For Each shp In ActiveSheet.Shapes
            If shp.Name <> "スイッチ" Then
                Debug.Print "【" & shp.Name & "】を削除する"
                shp.Delete
            Else
                Debug.Print "【" & shp.Name & "】は残します"
            End If
        Next

    End Sub

あと、動く動かないじゃなくて、ステップ実行してどこが思う通り動いてないのか調べませんか？
おっしゃる通りの状況（スイッチという名前の図形も"削除"されている）であれば、

    If shp.Name <> "スイッチ" Then
        shp.Delete  '←スイッチという名前の図形なのに実行されてしまっている
    End If

ということですから、ステップ実行で確認しつつ動かせば、想定通りの動きをしているかどうかすぐわかりますよね？

また、質問とは関係ないけど、なんで　アクティブシートにある「ステップ」という名前以外のシェイプを削除するって動きを2回やってるんですか
アクティブシートを切り替えてるわけでもないから、2番目の部分意味がないと思いますが。。

（もこな２） 2019/01/22(火) 23:38

ステップ実行してみました
Option Explicit

 Sub 名前定義範囲外削除_行列ver()

    Dim rng As Range
   Dim shp As Shape
    Set rng = Range("取り込み")

For Each shp In ActiveSheet.Shapes
If shp.Name <> "スイッチ" Then shp.Delete←　ここで図形が消えてしまいます

尚

    Sub 実験()
        Dim shp As Shape

        For Each shp In ActiveSheet.Shapes
            If shp.Name <> "スイッチ" Then
                Debug.Print "【" & shp.Name & "】を削除する"
                shp.Delete
            Else
                Debug.Print "【" & shp.Name & "】は残します"
            End If
        Next

    End Sub

については残しますと出てきました

（ひろ） 2019/01/23(水) 12:55

とりあえず
Sub テスト()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Name <> "スイッチ" Then shp.Delete
Next
End Sub
では図形は名前のつけた図形は残りました
謎です
（ひろ） 2019/01/23(水) 22:42

＞ステップ実行してみました
＞ If shp.Name <> "スイッチ" Then shp.Delete←　ここで図形が消えてしまいます

う～ん、わからないですね。
本当にそこを通った瞬間に消えた（削除された）のであれば、高さ0の図形になっているわけでもないでしょうし、「スイッチ」という名前ではないと判定されたことになるので、そうなると私のスキルでは対応できないっぽいです。
他の回答者さんをお待ちください。

（もこな２） 2019/01/24(木) 07:51

こんにちは。
図形の削除が論点になっているようですが
その理由が分かりません。
WEBクエリーはテキストベースですから
図形を取り込んでいません。
図形は増えも減りもしません。
議論している図形って何ですか？
（γ） 2019/01/24(木) 12:36

マクロを実行するために作成してるボタンです
（ひろ） 2019/01/24(木) 14:20

隠居じーさんさん
やはり図形の高さが０でした
どうすればいいでしょうか
（ひろ） 2019/01/24(木) 16:47

図形を置いて、それを含む行を消すと、デフォルトでは図形の大きさがセルに合わせて変化してしまいますよ？もしかして、「スイッチ」が消えたのではなく、高さ0になって見えなくなっただけで、消えてないのでは？

図形のサイズがセルに合わせて変わって欲しくないなら、図形を右クリックし、「書式設定」－「プロパティ」で、「セルに合わせて移動やサイズ変更をしない」を選択しておいてはいかがでしょうか？
（???） 2019/01/24(木) 16:57

試してみたところ、図形が含まれるセル範囲全てを削除すると、デフォルトでは図形も一緒に削除されるようですね。つまり、図形の削除抑止ロジックは効いていたけど、セル範囲削除で消されていた、という事でしょうか。消されない対策は、先に書いた通りです。
（???） 2019/01/24(木) 17:05

（ひろ）さん
すみません
あまり図形は詳しく無くて。
？？？さん、γさん。。。その他の回答者の
皆さんが的確なアドバイスをされていると
思いますので。
私はこれで失礼致します。
お役に立てませんで済みません。m(_ _)m
でわ

（隠居じーさん） 2019/01/24(木) 17:50

マクロはクイックアクセスツールバーに登録すれば
良いのでは？
削除、登録を繰り返すのは無駄では？
（γ） 2019/01/24(木) 18:00

解決しましたありがとうございます

（ひろ） 2019/01/24(木) 18:18

結局、Mougにマルチポストしてそっちで解決したっぽいのでもうココみてないだろうけど

                ↓
https://www.moug.net/faq/viewtopic.php?t=77870

Excel97なんかのときは、セルを削除すると高さ0のオブジェクトになっていて、調べてみるとたんまりと残っているとか、エクセルあるあるだったとおもうんですけど、???さんの 2019/01/24(木) 17:05投稿のとおり、最近のエクセルでは、「セルに合わせて移動やサイズ変更をする」になっていると、高さ0になるのではなく、セルの"削除"に追従して、オブジェクトも"削除"されるようですね。（Excel2007、2013、2016でテストしてみました。）

なので、私が2019/01/22(火) 22:38に投稿した、あと考えられるのは～　は誤りでした。ごめんなさい。

そして、たぶん
＞ステップ実行してみました
＞ If shp.Name <> "スイッチ" Then shp.Delete←　ここで図形が消えてしまいます
これは、勘違いで、実際には↓のどこかでセルの"削除"に追従して"削除"されたのだとおもいます。

    Range(rng(rng.Count).Offset(1), Cells(Rows.Count, 1)).EntireRow.Delete
    Range(rng(rng.Count).Offset(0, 1), Cells(1, Columns.Count)).EntireColumn.Delete
    If rng(1).Row > 1 Then
        Range(rng(1).Offset(-1), Cells(1, 1)).EntireRow.Delete
    End If
    If rng(1).Column > 1 Then
        Range(rng(1).Offset(0, -1), Cells(1, 1)).EntireColumn.Delete
    End If

また、Mougのほうは気づいて直したのか、偶然に直ったのかわかりませんが、こちらのサイトでは

 For Each shp In ActiveSheet.Shapes
  If shp.Name <> "スイッチ" Then shp.Delete
 Next

↑が2回出てくるので意味が無いってず～っとツッコんでました。
（実際のコードが直っているなら要らぬ心配ですが念のため）

（もこな２） 2019/01/28(月) 12:46

気づいてしまったので一応・・・

 (1)
[[20190115223521]]　『データが何故か行が空く』（ブル）
  ↑
マルチポスト
　↓
https://www.moug.net/faq/viewtopic.php?t=77842
データが三行空く
投稿日時: 19/01/15 20:04:52 投稿者: YAMA_HITO
 ↓
https://www.moug.net/faq/viewtopic.php?t=77877
データが三行空くについて
投稿日時: 19/01/27 22:52:16 投稿者: YAMA_HITO

 (2)
[[20190121213642]]　『３つのマクロを一つにまとめたい』（ひろ）
  ↑
マルチポスト
　↓
https://www.moug.net/faq/viewtopic.php?t=77870
名前のつけた範囲以外を削除しようとすると名前のつけた図形まで消えてしまう
投稿日時: 19/01/24 14:28:19 投稿者: YAMA_HITO

 (3)
[[20190118172923]]　『webクエリで取得した表の処理について』（ひろ）
  ↑
マルチポスト
　↓
https://www.moug.net/faq/viewtopic.php?t=77854
webクエリで取得した表の処理
投稿日時: 19/01/20 19:03:13 投稿者: YAMA_HITO

という関係にあるので、どうも
（ブル）＝（ひろ）＝Mougに投稿しているYAMA_HITO
ということのようです。

こちらのサイトはマルチポストOKを謳ってはいますが、嫌悪感を示す方もすくなからずおられるので、マルチポストするならするで明確にそのことを書いておいた方がよいでしょうし、規約にも

[マルチポストで書き込んだ方]は他の掲示板で解決した内容をこのボードでも公開して、書き込みが将来他の人の役に立つように協力してください

とあるので、ちゃんと実行されたほうがよいでしょう。
（Mougのほうは規約に書いてないですけど、同じことをしたほうがよいとおもいます。）

とりあえず私は、

回答中の方が見つけた場合その書き込みからの退散も自由です

ですから、このサイトで質問者さんからの質問だか丸投げ中のトピックはいくつかありますけど、しばらく静観します。

（もこな２） 2019/01/28(月) 14:21

コメント返信：

[ 一覧(最新更新順) ]

[[20190121213642]] 『３つのマクロを一つにまとめたい』（ひろ） ページの最後に飛ぶ

[[20190121213642]]　『３つのマクロを一つにまとめたい』（ひろ）　ページの最後に飛ぶ