[[20190715202938]]　『マクロ実行後、シートのコピーが手動でもできなく』（chip）　ページの最後に飛ぶ

『マクロ実行後、シートのコピーが手動でもできなくなる』（chip）

マクロの内容は、
1,コピー先のシートをダイヤログで選択してもらいブックを開く。
1-2,この時キャンセルされるとマクロ停止。
2,コピー元に戻りアクティブシートをコピー先にコピーする。
3,コピー元のシートにはシートモジュールが組み込まれているシートがあるので、コピー先の拡張子が.xlsmでは無かったら、拡張子を変更して名前をつけて保存して元の拡張子のブックを削除する。
4,コピー先のブックを閉じてマクロは終了。
この流れになってます。1度目の実行はできるのですが、再度同じコピー先にシートをコピーしようとすると、シートコピーするところでエクセルが強制終了されます。
この現象はマクロで実行、手動でシートコピーどちらでも発生します。
ですが、1回目のマクロ実行後にコピー先のシートを開きなにもせずに保存し閉じた後にマクロを実行すると正常に実行でき、次は同様の事象が発生してしまいます。

以下コードです。※手打ちしているため間違えてるかもしれませんが1回目は正しく動作します。
Sub マクロ登録()
Dim tbook As String
Dim wb As Workbook
Dim stopM As Boolean

tbook=ActiveWorkbook.Name
Set wb=Workbooks(tbook)
Call シート移動(stopM)
~~~~
Sub シート移動(ByRef f As Boolean)
Dim Myname As String
Dim wb1 As Workbook,wb2 As Workbook
Dim ws As Workseet,w As Worksheet
Dim flag As Boolean

Set wb1=ActiveWorkbook
Set ws=ActiveSheet
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect=True
.InitialFileName=“\\〇〇○“
If .Show=-1 Then
.Execute
Else
f=True
Exit Sub
End If
End With

Set wb2=ActiveWorkbook
wb1.Activate
ws.Copy After:=wb2.Sheets(1)
Myname=InputBox(“シート名入力”)
ActiveSheet.Name=Myname
Set wb1=Nothing
Set wb2=Nothing
Set ws=Nothing
End Sub
~~~~~
If stopM Then Exit Sub’シート移動のダイヤログで開く以外の操作した場合はマクロ終了
Call ファイル保存
~~~~~
Dim fso As Object
Dim n As String,ff As String,x As String,fu As String
Set fso = CreateObject(“Scriping.FileSystemObject”)
ff=ActiveWorkbook.FullName
fn=ActiveWorkbook.Name
x=“.” & fso.GetExtensionName(ff)
n=Left(fn,Len(fn)-Len(x))

If x = “.xlsm” Then
ActiveWorkbook.Save
ActiveWorkbook.Close
Else
ActiveWorkbook.SaveAs Filename:=“\\○〇〇\” & n & _
“.xlsm”,FileFormat:=xlOpenXMLWorkbookMacroEnabled

ActiveWorkbook.Close
Kill ff
End If
Set fso=Nothing
End Sub
~~~~~~~~~~~

wb.Activate
シートをリセットするコードが入る。
Set wb=Nothing
End Sub

＜使用 Excel：Excel2016、使用 OS：Windows10 ＞

プロシージャの最初と最後が不明です。
あなたの入力ミスと判別不能ですので、
デバッグ依頼として不成立です。
（γ） 2019/07/15(月) 22:12

γさん申し訳ございません。再度貼り付けます。
Sub マクロ登録()
Dim tbook As String
Dim wb As Workbook
Dim stopM As Boolean

tbook=ActiveWorkbook.Name
Set wb=Workbooks(tbook)
Call シート移動(stopM)
If stopM Then Exit Sub’シート移動のダイヤログで開く以外の操作した場合はマクロ終了
Call ファイル保存
wb.Activate
Set wb=Nothing
End Sub
~~~~~~~~~~~~~~~
Sub ファイル保存()
Dim fso As Object
Dim n As String,ff As String,x As String,fu As String
Set fso = CreateObject(“Scriping.FileSystemObject”)
ff=ActiveWorkbook.FullName
fn=ActiveWorkbook.Name
x=“.” & fso.GetExtensionName(ff)
n=Left(fn,Len(fn)-Len(x))

If x = “.xlsm” Then
ActiveWorkbook.Save
ActiveWorkbook.Close
Else
ActiveWorkbook.SaveAs Filename:=“\\○〇〇\” & n & _
“.xlsm”,FileFormat:=xlOpenXMLWorkbookMacroEnabled

ActiveWorkbook.Close
Kill ff
End If
Set fso=Nothing
End Sub
~~~~~~~~~~~~~~~~~~~~~~~
Sub シート移動(ByRef f As Boolean)
Dim Myname As String
Dim wb1 As Workbook,wb2 As Workbook
Dim ws As Workseet,w As Worksheet
Dim flag As Boolean

まず、質問者が行なっていることは、自己増殖型のウィルスソフトであると判断されてもおかしくないことを認識して下さい。
目的を達成する手段としては、別なアプローチがあると考えます。

で、問題ですが、コピー元のシートモジュールにどんなコードが書かれているのでしょうか？
考えられる事としては、変数、定数の競合、シートオブジェクト名の異常などがあります。

（渡辺ひかる） 2019/07/15(月) 22:51

渡辺ひかるさん回答ありがとうございます。
マクロを触りだしたところでそのような認識はありませんでした。

コピー元のシートモジュールは以下です。
指定したセルが選択されるとチェックと日付が入力されるようになってます。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ma As String

ma = Range("D2")'入力されている最大行数をD2セルに関数算出してます。

If Target.CountLarge > 1 Then Exit Sub
With Target
If Not .Column = 7 Then Exit Sub
End With
If Target.Row < 19 Then Exit Sub
If Target.Row > ma Then Exit Sub

If Target.Value = "" Then
Target.Value = "P"
Target.Font.Name = "Wingdings 2"
Target.Offset(, 2).Value = Date
ElseIf Target.Value = "-" Then Exit Sub

Else
Target.Offset(, 2).Value = ""
Target.Offset(, 0).Value = ""
End If
Set Target = Nothing
End Sub

（chip） 2019/07/15(月) 23:36

■
とりあえず、こだわり無いならインデント付けたほうがいいとおもいます。
（誰かに見せるつもりなら、見やすいほうがよいでしょうし、見やすくなればご自身のデバッグ作業もはかどりますよ）

■
↓で複数ブックを選択可能にしてますが、提示されたコードだと複数選択されると困りませんか？

 .AllowMultiSelect = True

■
ダメとはいいませんが、個人的にはActive○○に依存するコードは避けたほうがよいとおもいます。

■
プロシージャを複数に分けてますが、何か目的あるんでしょうか？
本件の場合は複雑化するだけなのでやめたほうがよいような・・

■
投稿されたコードに、インデントとコメント付けつつ合体させて、さらにループ処理に変えてみました。
興味があればステップ実行して、研究（各変数に何が格納されるか、どのような挙動になるか）してみてください。
（部分的にはテストしましたけど、全体はコンパイルエラーにならないことしかチェックしてないのでミスっていたらごめんなさい。）

    Sub 合体()
        Const MyPath As String = "\\〇〇○"
        Dim buf As Variant
        Dim srcSH As Worksheet: Set srcSH = ActiveSheet
        Dim tmp As String

        '▼ダイアログを開いてユーザーにブックを選択させる（複数可）
        With Application.FileDialog(msoFileDialogOpen)
            .AllowMultiSelect = True
            .InitialFileName = MyPath

            '▼キャンセル等が押されたらプログラム終了
            If .Show = 0 Then Exit Sub

            '▼ループ処理
            For Each buf In .SelectedItems

                '▼ブックを開いて操作対象に
                With Workbooks.Open(buf)

                    '▼シートをコピーしてユーザーに名前を入力してもらう
                    srcSH.Copy After:=.Sheets(1)
                    .Sheets(2).Name = InputBox("シート名入力")

                    '▼（開いたブックの）拡張子を除いたブック名を取得
                    tmp = Left(.Name, InStrRev(.Name, ".") - 1)

                    '▼（開いたブック）を名前を付けて保存して閉じる(同名ファイルがあっても強制上書き)
                    Application.DisplayAlerts = False
                    .SaveAs _
                        Filename:=MyPath & tmp, _
                        FileFormat:=xlOpenXMLWorkbookMacroEnabled
                    Application.DisplayAlerts = True
                    .Close
                End With

            Next buf

        End With

    End Sub

（もこな２） 2019/07/16(火) 01:51

シートイベントのほうも、いちいち選択しなおすたびにマクロが発動するのも煩わしいとおもうので、BeforeDoubleClickイベントに変更して整理してみました。

    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
        Cancel = True

        With Target

            '▼処理対象か判定
            If Not .Column = 7 Then Exit Sub
            If .Row < 19 Then Exit Sub
            If .Row > Range("D2").Value Then Exit Sub

            '▼Targetの値で条件分岐
            Select Case .Value

                Case ""
                    .Value = "P"
                    .Font.Name = "Wingdings 2"
                    .Offset(, 2).Value = Date

                Case "-"
                    '何もしない

                Case Else
                    .Offset(, 2).Value = ""
                    .Value = ""

            End Select

        End With

    End Sub

（もこな２） 2019/07/16(火) 02:08

＞シートコピーするところでエクセルが強制終了されます。
肝心の質問の方は私には原因はわかりませんが、どの部分で落ちるかわかっているということは、ステップ実行して調べた結果でしょうか？

もし、そうでなくて、ただの推測だったら、一度ステップ実行してみて確認したほうがよいとおもいます。

 x=“.” & fso.GetExtensionName(ActiveWorkbook.FullName) 
 If x = “.xlsm” Then ActiveWorkbook.Close

 ↑のようになっているので、正常に終了されているだけという可能性を疑っています。

（もこな２） 2019/07/16(火) 03:05

もこな２さん
ありがとうございました！とても勉強になりました！
思う通りの動きになり、不具合の発生もありませんでした。
シートモジュールに関しても修正ありがとうございました。
ステップ実行してみましたが、毎回シートコピーのタイミングで強制終了していました。
Set ○○=Nothingをつける前はそのタイミングでオートメーションエラーが発生していました。

＞とりあえず、こだわり無いならインデント付けたほうがいいとおもいます。
これからそうしようと思います。

＞↓で複数ブックを選択可能にしてますが、提示されたコードだと複数選択されると困りませんか？
ネットよりコピペでもってきていたので何をしているコードなのか理解していませんでした。

＞ダメとはいいませんが、個人的にはActive○○に依存するコードは避けたほうがよいとおもいます。
これからそうします！

＞プロシージャを複数に分けてますが、何か目的あるんでしょうか？
それぞれで動くかを見るために分けてました。

（chip） 2019/07/16(火) 03:19

■
＞ネットよりコピペでもってきていたので何をしているコードなのか理解していませんでした
複数のファイルを選択させるつもりがないなら、

 .AllowMultiSelect = True  ←要らないとおもいます

■
初期フォルダもカレントフォルダでよいということならば、Application.GetOpenFilenameという手もあります。（好みの問題でしょうけど）

■
いずれにせよ、対象が複数じゃないならループ処理はしないほうがよさそうです。
（ややこしくなるだけなので）

    Sub 複数選択不可()
        Const MyPath As String = "\\〇〇○"
        Dim buf As Variant
        Dim srcSH As Worksheet: Set srcSH = ActiveSheet
        Dim tmp As String

        '▼ダイアログを開いてユーザーにブックを選択させる（複数不可）
        buf = Application.GetOpenFilename("Excel ブック,*.xls?")

        '▼キャンセルが押される等でbufが初期値のままだったらプログラム終了
        If buf = "" Then Exit Sub

        '▼ブックを開いて操作対象に
        With Workbooks.Open(buf)

            '▼シートをコピーしてユーザーに名前を入力してもらう
            srcSH.Copy After:=.Sheets(1)
            .Sheets(2).Name = InputBox("シート名入力")

            '▼（開いたブックの）拡張子を除いたブック名を取得
            tmp = Left(.Name, InStrRev(.Name, ".") - 1)

            '▼（開いたブック）を名前を付けて保存して閉じる(同名ファイルがあっても強制上書き)
            Application.DisplayAlerts = False
            .SaveAs _
                Filename:=MyPath & tmp, _
                FileFormat:=xlOpenXMLWorkbookMacroEnabled
            Application.DisplayAlerts = True
            .Close
        End With

    End Sub

（もこな２） 2019/07/16(火) 04:17

こちらで、できるだけ元のコードのままで、動くようにして
何度かテスト（同じブックにマクロシートを追加コピー）しましたが、固まる現象は
発生しませんでした

マクロシートのセルD2には　適当に　=COUNTA(G20:G29)+19　などと設定して動かしてみました。

もこな２さんのアドバイスのように、BeforeDoubleClickに変更して　トラブルがでなくなったのなら
論理的に考えてSelectionChangeが悪さをしていたということになります。

もうコードは変更してしまったと思いますので、検証はできないと思いますが

SelectionChangeのプロシージャの中に
Msgbox Me.name
などと記載して、予期しないイベントが発生していないかどうか確認するというのも
デバック手法の一つです

もう一つ気になるのが、マクロ登録プロシージャの起動方法です。
こちらでは、マクロ一覧のダイアログボックスから起動してテストしましたが
ボタンからの起動などで、SelectionChange　イベントが走ったりすると　固まるのかもしれません
あとは、提示された以外の部分からの影響ですが、イベントを変えたら治ったということなので、
考えにくいかなと・・・

最後に

Dim ma As String
ma = Range("D2")'入力されている最大行数をD2セルに関数算出してます。

です。
もこな２さんは　変数を省略していますが
この宣言は文字列ですよ。
Range("D2")に29　などの数値が入力されていたとしたら　maには"29" という文字列が代入されます
VBAは親切なので、文字列を数値と比較しても、数値と解釈できるものであれば、読み替えてくれるので
エラーにはならなかったと思いますが、

今後　変数の型などにも注意して　開発されることをお勧めします。

（渡辺ひかる） 2019/07/16(火) 09:33

渡辺ひかるさん
ありがとうございます！
Msgboxで確認する方法があったんですね、
今後このように確認しようとおもいます！

Stringで宣言しておけば間違い無いと思ってました。
以後気をつけます。ありがとうございました！
（chip） 2019/07/16(火) 10:37

＞この宣言は文字列ですよ。
本当だ。思いっきり見落としていました。フォローどもです。

ちなみに、「G19」以下ならどのセルでもということであれば、セルの値を使わずに↓でもよさそうです。
（ついでに、Cancel = Trueの位置を訂正）

    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

        With Target

            '▼処理対象か判定
            If Intersect(Target, Range("G19", Cells(Rows.Count, "G"))) Is Nothing Then Exit Sub

            Cancel = True

            '▼Targetの値で条件分岐
            Select Case .Value
                Case ""
                    .Value = "P"
                    .Font.Name = "Wingdings 2"
                    .Offset(, 2).Value = Date

                Case "-"
                    '何もしない

                Case Else
                    .Value = ""
                    .Offset(, 2).Value = ""

            End Select
        End With
    End Sub

（もこな２） 2019/07/16(火) 14:37

質問者のコードには

ma = Range("D2")'入力されている最大行数をD2セルに関数算出してます。

とありますので、最終行までではなく、データの最下行まで　の制限があるのでは？と思います。

私は勝手に推測して

マクロシートのセルD2には　適当に　=COUNTA(G20:G29)+19　などと設定して動かしてみました。

としています。

（渡辺ひかる） 2019/07/16(火) 15:04

渡辺ひかるさん、もこな2さん
このシートはチェックシートの原紙です。
なので、19行目から70行目までにチェック項目を入力する欄が設けられていまして、
そこに文字が入るとD2セルの数字が増えていくようになっています。

ただ、今のままだと途中に空白行が出た場合に対応できなくなります。
Offsetでずらして判断しようかとおもいましたが、やり方がわかりませんでした。
（chip） 2019/07/16(火) 15:31

スレを続けるかどうか微妙な質問ですが・・・

まずは現在の関数と　データの入力状況を　説明してください
対応できている場合と、対応できなくなる場合と・・・・

（渡辺ひかる） 2019/07/16(火) 15:40

渡辺ひかるさん
A19にIF(B19=“”,””,1)
A20以降にIF(B20=“”,””,MAX($B$19:B19)+1)が入ってます。
D2はMAX(A19:A70)+18
B19以降の行はチェック項目です。
G19以降がチェック欄で、
I19以降が日付が入力される欄となります。
なんども申し訳ございません。
（chip） 2019/07/16(火) 15:53

数式はわかりました

G列以降、I列以降　は今回の質問には無関係ですよね？

B列についてMAX関数を使っているということは、B列の値がどのような状況なのかわからないと
何とも言えません。

B19以降の行はチェック項目です。

とありますけどどのような値が入力されているのか？
単純な連番ですか？

こちらで、指示通りの数式を登録してB列に適当に入力してみましたが

B列への入力データの内容・ルールがわからないと、回答できないです。

ただ、今のままだと途中に空白行が出た場合に対応できなくなります。

この事例も提供していただいていません。

質問者のそばで同じシートを見ているわけではないので、
きちんと説明してください

（渡辺ひかる） 2019/07/16(火) 16:11

渡辺ひかるさん
B19以降はは文字データが入力されます。
途中で空白行の件ですが、
B19に文字データが入りA19は1
B20は空白でA20は空白
B21に文字データが入りA20は2となり
D2の結果は20となります。
この時にD20をダブルクリックするとチェックが入ってしまいます。
本当は、D21にチェックが入って欲しく、D20にはチェックが入らないようにしたいです。
（chip） 2019/07/16(火) 16:22

ですからどんな文字データが入っているのでしょう？

常識的に考えて文字データというのは、あいう　ABC　などになると思いますが、間違っていますか？

文字データが入っているセルに対して、MAX($B$19:B19)　という数値を対象とした関数を使うこと自体が
おかしいと思いますが・・・

例えば　新規シートのA1からA10　に　文字データ　"AAA1","AAA2"・・・・・"AAA10" と入力して
B1に　=MAX(A1:A10) としても　0が返るだけですよね？

質問者さんが書いていることはそういうことですよ？

この時にD20をダブルクリックするとチェックが入ってしまいます。本当は、D21にチェックが入って欲しく、D20にはチェックが入らないようにしたいです。

本当にコードを理解されていますか？
ダブルクリックイベントのTarget には、ダブルクリックされたセルが代入されており
そこに値とフォントをセットしているので、D2の値が範囲内であれば、同じように実行され
値とフォントがセットされるセルはD2の値には影響されません。

ダブルクリックしたセルと異なるセルにチェックが入るなどという仕様は、使う側としても戸惑うだけだと思いますけど・・

（渡辺ひかる） 2019/07/16(火) 16:41

渡辺ひかるさん
A20にはIF(B20=“”,””,MAX($A$19:A19)+1)のまちがいでした。

本当にコードを理解されていますか？申し訳ございません。理解できていなかったです。
では、If Select Case.Offset(,-6).Value=“” Then Exit Sub
みたいなことは可能なのでしょうか？手元にPCが無いため確認ができなく、、
（chip） 2019/07/16(火) 16:55

質問者さん

時間を置きましょう
PCもない状況では、そちらの状況も正確に把握できませんし

誤った情報で考えるのも疲れます。

そちらの状況が整った段階で、スレッドをもう一度読み直して
回答者がどのような情報を求めているか把握して、的確に提供してください

アドバイスはそれからです。

（渡辺ひかる） 2019/07/16(火) 17:40

渡辺ひかるさん
ありがとうございました！
後は自分で試行錯誤しながらやってみます！
（chip） 2019/07/16(火) 18:18

書き溜めている間に話が終わっちゃいましたが、書いたので投稿しておきます。

■（渡辺ひかる） 2019/07/16(火) 15:04のレスとして。

ちょっと勘違いされる書き方だったかもしれません。
「ちなみに～」以下は質問者さん向けに書いたものです。
元のコードで

 If Target.Value = "" Then

となっていましたので、ブランクセルの場合でも処理するケースがあるのだと判断して、Cells(Rows.count,"G")End(xlup)だと処理したい範囲が取得できないな～と思ったので【「G19」以下ならどのセルでも】と断って提示している次第です。

ちなみに、G列の対象セルが「""」ではなく、純粋なブランクセルだと「=COUNTA(G20:G29)+19」では正しく掴めないと思うので、歯抜けやブランクが無い別の列を見ているのだとおもいますが、レイアウトも数式も提示が無かったし、そこまで深掘りする必要もないと思った（めんどくさかったとも言う）のでG19～G列最下行までにしてみたというのも理由の一つです。

■chipさん向けレスとして
コメントの内容から推察して
Ａ列は数式が入っちゃってるから最終行取得には使えなさそう
Ｄ列も数式が入っちゃってるから最終行取得には使えなさそう
Ｇ列はブランクセルかもしれないから最終行取得には使えなさそう
・
・
って消去法で考えていくと
＞B19以降はは文字データが入力されます。
って仰っているので、対象範囲はＧ【列】かつ、19【行】目～Ｂ列の最下セルから上方向に見てヒットする【行】ということで良さそうに思います。

    Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

        With Target
            '▼処理対象か判定
            If Cells(Rows.Count, "B").End(xlpu).Row < 19 Then Exit Sub            
            If Intersect(Target, Range("G19", Cells(Cells(Rows.Count, "B").End(xlpu).Row, "G"))) Is Nothing Then Exit Sub
            Cancel = True

            '▼Targetの値で条件分岐
            Select Case .Value
                Case ""
                    .Value = "P"
                    .Font.Name = "Wingdings 2"
                    .Offset(, 2).Value = Date
                Case "-"
                    '何もしない
                Case Else
                    .Value = ""
                    .Offset(, 2).Value = ""
            End Select
        End With
    End Sub

ただ、個人的にはお話を読んでいると、最終行以下のG列を触るような運用になってなさそうですし、わざわざ下限？を設定しなくてもよさそうにおもうので、2019/07/16(火) 14:37　に提示したコードのように、G19～G1048576のどこでも　という条件も検討するだけでもしてみてほしいなぁとおもいます。

（もこな２） 2019/07/16(火) 23:15

もこな2さん
ありがとうございます。
明日より仕事なのでその際試してみます。

G列の下限？上限？は自分の考えでそんなチェック項目はないだろうという考えで設定していました。

（chip） 2019/07/18(木) 00:47

コメント返信：

[ 一覧(最新更新順) ]

[[20190715202938]] 『マクロ実行後、シートのコピーが手動でもできなく』（chip） ページの最後に飛ぶ

[[20190715202938]]　『マクロ実行後、シートのコピーが手動でもできなく』（chip）　ページの最後に飛ぶ