[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『別ブックにシートをコピー後、マクロの再登録』（とらじま）
いろいろ事例を探して試してみましたが、上手くいかず、困っています。
元ファイルには複数のシートと複数の標準モジュールが存在します。
複数シートの内、2つのシートと標準モジュール1つを、新しく作成したファイルにコピーし、デスクトップ上に名前を付けて保存します。
シートにはマクロボタンがあります。
新しく作成したファイルのマクロボタンのマクロの再登録をOnActionで行うのですが、コピー元のパスを参照してしまい、上手くいきません。
' 作成した工程表を別ファイルで保存
Sub 別名保存()
Dim Ws As Worksheet
Dim nm As Name
Workbooks.Add
'作成するシートと休日シートをコピー
ThisWorkbook.Worksheets("休日").Copy After:=ActiveWorkbook.Worksheets(Sheets.Count)
ThisWorkbook.Worksheets(ShName).Copy Before:=ActiveWorkbook.Worksheets(Worksheets.Count)
'標準モジュール6をコピー
Dim VBP, Code As String
With ThisWorkbook.VBProject.VBComponents("Module6").CodeModule
Code = .Lines(.CountOfDeclarationLines + 1, .CountOfLines - .CountOfDeclarationLines + 1)
End With
With ActiveWorkbook.VBProject.VBComponents.Add(1)
.CodeModule.AddFromString Code
End With
'マクロ実行中に警告やメッセージを表示させない
Application.DisplayAlerts = False
'不要なシートを削除
For Each Ws In Worksheets
If Ws.Name <> ShName And Ws.Name <> "休日" Then
Ws.Delete
End If
Next Ws
'名前の定義を【休日】・【色】以外削除
For Each nm In Names
If nm.Name <> "休日" And nm.Name <> "色" Then
nm.Delete
End If
Next nm
ActiveSheet.PageSetup.PrintArea = 印刷範囲
'改ページプレビューを標準にする
ActiveWindow.View = xlNormalView
Call デスクトップに保存
Sheets(1).Select
ActiveSheet.Shapes.Range(Array("工程塗色ボタン")).Select
ActiveSheet.Shapes(1).Select
Selection.OnAction = "工程表" & "!工程LINE"
Application.DisplayAlerts = True
'変更を保存せず、元のファイルを閉じる
ThisWorkbook.Saved = True
ThisWorkbook.Close
End Sub
Sub デスクトップに保存()
Dim Path As String
Dim WSH As Variant
Set WSH = CreateObject("WScript.Shell")
Path = WSH.SpecialFolders("Desktop") & "\"
ActiveWorkbook.SaveAs Filename:=Path & "工程表.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Set WSH = Nothing
End Sub
元ファイル名：工程表作成
新しいファイル名：工程表
マクロ名：工程LINE
エラーは起きず、デスクトップ上に新しいファイル（工程表）の作成は出来て、元のファイルも保存せず閉じますが、マクロボタンの登録が元のファイルのまま、【'C:\Users\kuron\Desktop\工程表作成.xlsm'!工程LINE】となります。OnActionで、ここを新しいファイルの工程表の【工程LINE】と変えたいのですが出来ません。
よろしくお願いします。
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
With ThisWorkbook.VBProject.VBComponents("Module6").CodeModule
Code = .Lines(.CountOfDeclarationLines + 1, .CountOfLines - .CountOfDeclarationLines + 1)
End With
With ActiveWorkbook.VBProject.VBComponents.Add(1)
.CodeModule.AddFromString Code
End With
ActiveSheet.Shapes(1).OnAction = "工程LINE"
Call デスクトップに保存
の順にやればイケるのではないでしょうか?
（白茶） 2020/07/06(月) 19:23
ご回答ありがとうございます。
残念ながらダメでした。
私も 『Call デスクトップに保存』を後に書いていたのですが、
先に保存して確定しないと変わらないと思い、今の順番にしました。
ActiveSheet.Shapes(1) にしましたが、変わりません。
どうしても、元のファイル名が付きます。
（とらじま） 2020/07/07(火) 13:48
あら、そうなんですか。 もちろん元のまま ActiveSheet.Shapes(1).OnAction = "工程表" & "!工程LINE" とかでやってないですよね?
試しに
Module1 *********************************************************************************************
Sub test()
Dim Code As String
Workbooks.Add
ActiveSheet.Shapes.AddShape msoShapeRectangle, 72, 72, 72, 72
With ThisWorkbook.VBProject.VBComponents("Module6").CodeModule
Code = .Lines(.CountOfDeclarationLines + 1, .CountOfLines - .CountOfDeclarationLines + 1)
End With
With ActiveWorkbook.VBProject.VBComponents.Add(1)
.CodeModule.AddFromString Code
End With
ActiveSheet.Shapes(1).OnAction = "工程LINE"
Call デスクトップに保存
End Sub
Sub デスクトップに保存()
Dim Path As String
Dim WSH As Variant
Set WSH = CreateObject("WScript.Shell")
Path = WSH.SpecialFolders("Desktop") & "\"
ActiveWorkbook.SaveAs Filename:=Path & "工程表.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
Set WSH = Nothing
End Sub
Module6 *********************************************************************************************
Sub 工程LINE()
MsgBox "工程LINE"
End Sub
↑だけのブックを作って実行してみましたが、まともに動きました(当方Excel2010ですけど) これでも私と違う結果なら、私にはわかんないです。
(実はDisplayAlerts切らずに実行したら、どこかで失敗してたりして) なんて、コッソリ思ったりしてます。
（白茶） 2020/07/07(火) 18:05
ActiveSheet.Shapes(1).OnAction = "工程表" & "!工程LINE" ではなく、
= "工程LINE" としております。
試しで記載いただいた『test』の図形を追加作成しての登録は上手くいきました。
同じブックで、マクロの登録（OnAction）の部分を、図形を追加して登録（下記）に変えて、元のブックではなく、"工程LINE”のみの登録名になりました。
ActiveSheet.Shapes.AddShape msoShapeRectangle, 72, 72, 72, 72
ActiveSheet.Shapes(1).OnAction = "工程LINE"
なので、予め用意したボタンのマクロ登録変更が上手くいかないのかと思い、
ボタンを削除して、新たにボタンを追加して登録しようと下記コードで試しましたが、
出来ませんでした。どうしても元のファイル名が付いてしまいます。
With ActiveSheet.Buttons.Add(Range("B3").Left, _
Range("B3").Top, _
Range("B3").Width, _
Range("B3").Height)
.OnAction = "工程LINE"
.Characters.Text = "塗色"
End With
図形だと上手くいくのですが、ボタンだと駄目なのでしょうか。
よろしくお願いします。
（とらじま） 2020/07/08(水) 16:08
おお!! ボタンなら現象再現出来ましたよ。
Sub test()
Dim Code As String
Workbooks.Add
' ActiveSheet.Shapes.AddShape msoShapeRectangle, 72, 72, 72, 72
ActiveSheet.Buttons.Add Range("B3").Left, Range("B3").Top, Range("B3").Width, Range("B3").Height
Rem 試しにわざと元ブックのマクロを登録 -------------------
With ActiveSheet.Buttons(1)
.OnAction = "工程LINE"
End With
Stop '確認用ストップ
Rem ------------------------------------------------------
With ThisWorkbook.VBProject.VBComponents("Module6").CodeModule
Code = .Lines(.CountOfDeclarationLines + 1, .CountOfLines - .CountOfDeclarationLines + 1)
End With
With ActiveWorkbook.VBProject.VBComponents.Add(1)
.CodeModule.AddFromString Code
End With
' ActiveSheet.Shapes(1).OnAction = "工程LINE"
With ActiveSheet.Buttons(1)
.OnAction = ActiveWorkbook.Name & "!工程LINE"
.Characters.Text = "塗色"
End With
Call デスクトップに保存
End Sub
とりあえず↑でやってみたら、なんとかなってるっぽいです(こちらの環境では)
実行後、改めて工程表.xlsmを開いて ボタンの[マクロの登録]でマクロ名を確認したら [工程表.xlsm!工程LINE]になってました。
（白茶） 2020/07/08(水) 17:10
出来ました！
【ActieWorkbook.Name & "!工程LINE"】
とすると、ボタンの追加でなく、元からあるボタンでも登録名変更が出来ました。
ファイル名を直接記載ではなく、【ActieWorkbook.Name】としないといけないのですね。
できれば、ファイル名が付かない [工程LINE] で登録できればスッキリしますが、
ボタンだと、ファイル名が前に付いてしまうのですね。
何かスッキリしませんが、動くので、こちらで進めようと思います。
ありがとうございました。
感謝！
（とらじま） 2020/07/08(水) 17:59
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.