Excel2016 : 選択したシートを新しいブックとして独立させる

2010までのExcelはMDIでして。大きな「Excel」というウィンドウの中に、ロードしたファイルが子ウィンドウとして複数表示できるような仕組みになっていました。

これで便利だったことのひとつに、「ワークシートのタブを掴んでを親ウィンドウにドロップすると、そのシートが独立した新しいブックになる」ってのがありまして。
がんがんシートを増やして書きたいこと書いてから、複数のブックファイルに分割する際など非常に楽ちんだったのです。

これが2013以降SDIになっちゃいまして。
今まで子ウィンドウで表示されていた個々のブックファイルが、独立したウィンドウとして表示されるようになってしまいました。

これでいろいろと不便を強いられているのですが、代表的な不便さのひとつに、上記のドロップ分割が使えなくなってしまったことがあります。

2010までは、移動なら

外に出したいシートを選択する
選択したシートを親ウィンドウにドロップする

コピーなら

外に出したいシートを選択する
選択したシートを親ウィンドウに、Ctrlキーを押しながらドロップする

の2アクションだった作業が、2013からは

外に出したいシートを選択する
タブを右クリックしたコンテキストメニューから「移動またはコピー」を選択する
「移動先ブック名」から「(新しいブック)」を選択する
コピーするなら「コピーを作成する」にチェックをつける
「OK」をクリックする

と、驚きの5アクション。なんだか妙にまどろっこしくなってしまいました。

もうちょい手数を減らすなら、

ctrl+Nで新しいブックを作成する
元ブックで外に出したいシートを選択する
選択したシートを新しいブックにドロップする
新しいブックの不要なシートを削除する

で4アクション。1アクション分の節約ですね。

これはさすがにやっとられないので、2アクションくらいで同様の動作ができるように考えてみることにしました。

コンテキストメニューからコマンド選択一発

操作性の向上が目的ですので、操作性部分のコーディングから入ります。
CommandBar各種のNameを取得するで調べたとおり、CommandBars("Ply")のControlsに新しい項目を追加してやればいいわけですから、項目の表示名を「シートの切り出し(C)」、呼び出すプロシージャ名を「CuttingOutSheet」として、こんな感じで。

Public Sub AddMenu_SheetSeparate()

    Dim mnuItem As CommandBarControl
    
    '*** 項目の追加
    Set mnuItem = Application.CommandBars("Ply").Controls.Add(, , , , True)
    mnuItem.Caption = "シートの切り出し(&C)"
    mnuItem.OnAction = "CuttingOutSheet"
    mnuItem.BeginGroup = False
    
End Sub

実行した結果もこんな感じで。

なんか .BeginGroup=False が効いてません。
まあ本筋ないので気にしません。効かないんですから記述削除しちゃえばいいんですよね。
で、念のためもう一度実行すると、

だめだ、実行した回数だけ同じ項目が増えます。

しかたがないので、表示名を指定して項目を削除するプロシージャも用意します。

'*****************************
' コンテキストメニューからの項目の削除
'*****************************
Public Sub RemoveMenu_SheetSeparate(pBar As String, pCap As String)

    Dim itm As CommandBarControl
    
    '*** 操作を間違うと同じ項目が複数登録できちゃうので殲滅ループ
    For Each itm In Application.CommandBars(pBar).Controls
        If itm.Caption = pCap Then itm.Delete
    Next
    
End Sub

元のプロシージャも修正して、

'************************************
' シートタブコンテキストメニューへの項目の追加
'************************************
Public Sub AddMenu_SheetSeparate()

    Dim mnuItem As CommandBarControl
    Dim pBar As String: pBar = "Ply"
    Dim pCap As String: pCap = "シートの切り出し(&C)"
    
    '*** 同じ項目が以前に登録されていたら削除
    Call RemoveMenu_SheetSeparate(pBar, pCap)
    
    '*** 項目の追加
    '   Addコマンドの第5引数はTrue/False=一時/恒常
    '   「一時」はExcel.exeが終了するまで(ひとつのプロセス内複数ブックで共有)
    Set mnuItem = Application.CommandBars(pBar).Controls.Add(, , , , True)
    mnuItem.Caption = pCap
    mnuItem.OnAction = "CuttingOutSheet"
    mnuItem.BeginGroup = True
    
End Sub

あとはダミーでCuttingOutSheetプロシージャを作ってやれば、とりあえずコンテキストメニューからのプロシージャ呼び出しを確認できますね。

Public Sub CuttingOutSheet()

    MsgBox ("Test")

End Sub

コピーと移動を起動し分ける

MDI環境でのシートの切り出しは、普通にドラッグすれば移動、ctrlキーを押しながらのドラッグでコピーになっていました。
この操作性になるべく近づけたいので、コンテキストメニューから「シートの切り出し」をクリックすれば移動、ctrlキーを押しながらクリックすればコピーとして動作するようにしたいんです。

VBAには、キーの押下状態を知る方法はありません。
ですので、ここでは指定キーの押下状態を取得するWinAPIを使うことにします。

しかし、WinAPIは32bitと64bitで宣言が異なります。

幸い、VBAは7からWin64というコンパイル定数が用意されるようになりましたので、#IFディレクティブと組み合わせればWinAPIを宣言し分けることが可能です。

#If Win64 Then
    Declare PtrSafe Function GetAsyncKeyState _
        Lib "User32.dll" (ByVal vKey As Long) As Integer
#Else
    public Declare Function GetAsyncKeyState _
        Lib "user32" (ByVal nVirtKey As Long) As Long
#End If

こんな感じになりますね。
ただし私の環境は64bitなので、32ビット用宣言の動作検証はしていません。間違ってたらごめんなさい。

で、先ほどのダミーCuttingOutSheetプロシージャを、ctrlキーの押下状態をチェックできるようなものに書き換えてみます。

Public Sub CuttingOutSheet()

    Dim CtlFg       As Boolean
    
    CtlFg = GetAsyncKeyState(vbKeyControl)
    MsgBox (IIf(CtlFg, "ctrl-ON", "ctrl-OFF"))

End Sub

これで、ｃｔｒｌキーの押下状態を取得できるようになりました。
実際に、ctrlキーを押したり押さなかったりしながら「シートの切り出し」項目をクリックして表示されるMsgBoxの違いをお楽しみください。

選択したシートをコピーまたは移動する

コピー/移動したいシートはひとつ選択、複数選択する場合があります。選択しているシートだけを引っ張り出すには、SelectedSheetsコレクションを使います。で、このコレクションには複数の種類のオブジェクトが混ざる場合がありますので、For Eachループの受け変数にはVariantを使うことになります。

このへんをコードに起こすと、

Public Sub CuttingOutSheet()

    Dim CtlFg       As Boolean
    Dim ActWdw      As Window
    Dim newWb       As Workbook
    Dim sht         As Variant
        
    CtlFg = GetAsyncKeyState(vbKeyControl)

    '*** 新しいWorkbookの作成 → 元のウィンドウからフォーカスが外れるので、あらかじめ取得しておく
    Set ActWdw = ActiveWindow
    Set newWb = Workbooks.Add()
    
    '*** 選択したシートのコピー/移動
    For Each sht In ActWdw.SelectedSheets
        Select Case CtlFg
            Case True   'コピー
                Call sht.Copy(after:=newWb.Sheets(newWb.Sheets.Count))
            Case False  '移動
                Call sht.Move(after:=newWb.Sheets(newWb.Sheets.Count))
        End Select
    Next

End Sub

となります。SelectedSheetsコレクションはWorkbookではなくWindowオブジェクトにぶら下がるコレクションだということ、元/新ブックを同時に扱うのでActiveWindowがプロシージャの途中でずれるので事前に変数にインスタンスを保持しとくこと、あたりがポイントでしょうか。

上記コードを実行してみると、新しいブックの結果はこんな感じになります。

…ブック作成時のシートがまんま残ってますし、シート名がカブっていると「(2)」とか付いちゃってますね。ダメかもう一工夫要るか。とほほ。

ブックの後始末をする

よけいなシートの削除は割と簡単。新ブック作成時のシート数を押さえておいて、コピー/移動後に左側からそのシート数分だけ削除しちゃえばOKですね。

「(2)」とかを削除…はできませんね。コピー/移動対象のシートにもともと「(2)」などがついていると削除しちゃいけないので、シート名の文字列から切り取るわけにもいきません。
ので、コピー/移動時にシート名を保持しといて、あとで書き戻せばいいんじゃないかと。

このへんを追加すると、以下のようなコードになりますね。

'***************************************
' 選択されたシートをまとめて新しいブックへ切り出し
'   (Ctrlキー同時押下で新しいブックへコピー)
'***************************************
Public Sub CuttingOutSheet()

    Dim CtlFg       As Boolean
    Dim ActWdw      As Window
    Dim ActWb       As Workbook
    Dim newWb       As Workbook
    Dim shtCnt      As Integer
    Dim sht         As Variant
    Dim idx         As Integer
    Dim shtName()   As String
    Dim snCnt As Integer: snCnt = 0

    '*** Ctrlキー押下状態の取得 → True/False=On/Off=コピー/移動
    CtlFg = GetAsyncKeyState(vbKeyControl)

    '*** 新しいWorkbookの作成 → 元のウィンドウからフォーカスが外れるので、あらかじめ取得しておく
    Set ActWdw = ActiveWindow
    Set ActWb = ActiveWorkbook
    Set newWb = Workbooks.Add()
    shtCnt = newWb.Sheets.Count
    
    '*** 選択したシートのコピー/移動
    For Each sht In ActWdw.SelectedSheets
        snCnt = snCnt + 1: ReDim Preserve shtName(snCnt)
        shtName(snCnt) = sht.Name
        Select Case CtlFg
            Case True   'コピー
                Call sht.Copy(after:=newWb.Sheets(newWb.Sheets.Count))
            Case False  '移動
                Call sht.Move(after:=newWb.Sheets(newWb.Sheets.Count))
        End Select
    Next
    
    '*** デフォルトシートの削除
    Application.DisplayAlerts = False
    For idx = 1 To shtCnt
        newWb.Sheets(1).Delete
    Next
    Application.DisplayAlerts = True

    '*** シート名の付け直し
    For idx = 1 To snCnt
        newWb.Sheets(idx).Name = shtName(idx)
    Next

End Sub

ここまでやればひととおりイケるかなーと思いますよ。

まとめ

ちょっと長くなったので、手順をまとめます。

新しいブックを作成して、
VBEを起動して、
標準モジュールを作って、
以下のコードをまとめて貼ります。

Option Explicit

#If Win64 Then
    Declare PtrSafe Function GetAsyncKeyState _
        Lib "User32.dll" (ByVal vKey As Long) As Integer
#Else
    public Declare Function GetAsyncKeyState _
        Lib "user32" (ByVal nVirtKey As Long) As Long
#End If

'************************************
' シートタブコンテキストメニューへの項目の追加
'************************************
Public Sub AddMenu_SheetSeparate()

    Dim mnuItem As CommandBarControl
    Dim pBar As String: pBar = "Ply"
    Dim pCap As String: pCap = "シートの切り出し(&C)"
    
    '*** 同じ項目が以前に登録されていたら削除
    Call RemoveMenu_SheetSeparate(pBar, pCap)
    
    '*** 項目の追加
    '   Addコマンドの第5引数はTrue/False=一時/恒常
    '   「一時」はExcel.exeが終了するまで(ひとつのプロセス内複数ブックで共有)
    Set mnuItem = Application.CommandBars(pBar).Controls.Add(, , , , True)
    mnuItem.Caption = pCap
    mnuItem.OnAction = "CuttingOutSheet"
    mnuItem.BeginGroup = True
    
End Sub

'*****************************
' コンテキストメニューからの項目の削除
'*****************************
Public Sub RemoveMenu_SheetSeparate(pBar As String, pCap As String)

    Dim itm As CommandBarControl
    
    '*** 操作を間違うと同じ項目が複数登録できちゃうので殲滅ループ
    For Each itm In Application.CommandBars(pBar).Controls
        If itm.Caption = pCap Then itm.Delete
    Next
    
End Sub

'***************************************
' 選択されたシートをまとめて新しいブックへ切り出し
'   (Ctrlキー同時押下で新しいブックへコピー)
'***************************************
Public Sub CuttingOutSheet()

    Dim CtlFg       As Boolean
    Dim ActWdw      As Window
    Dim ActWb       As Workbook
    Dim newWb       As Workbook
    Dim shtCnt      As Integer
    Dim sht         As Variant
    Dim idx         As Integer
    Dim shtName()   As String
    Dim snCnt As Integer: snCnt = 0

    '*** Ctrlキー押下状態の取得 → True/False=On/Off=コピー/移動
    CtlFg = GetAsyncKeyState(vbKeyControl)

    '*** 新しいWorkbookの作成 → 元のウィンドウからフォーカスが外れるので、あらかじめ取得しておく
    Set ActWdw = ActiveWindow
    Set ActWb = ActiveWorkbook
    Set newWb = Workbooks.Add()
    shtCnt = newWb.Sheets.Count
    
    '*** 選択したシートのコピー/移動
    For Each sht In ActWdw.SelectedSheets
        snCnt = snCnt + 1: ReDim Preserve shtName(snCnt)
        shtName(snCnt) = sht.Name
        Select Case CtlFg
            Case True   'コピー
                Call sht.Copy(after:=newWb.Sheets(newWb.Sheets.Count))
            Case False  '移動
                Call sht.Move(after:=newWb.Sheets(newWb.Sheets.Count))
        End Select
    Next
    
    '*** デフォルトシートの削除
    Application.DisplayAlerts = False
    For idx = 1 To shtCnt
        newWb.Sheets(1).Delete
    Next
    Application.DisplayAlerts = True

    '*** シート名の付け直し
    For idx = 1 To snCnt
        newWb.Sheets(idx).Name = shtName(idx)
    Next

End Sub

あと、ThisWorkbookモジュールにWorkbook_Openプロシージャを作って、AddMenu_SheetSeparateの呼び出しを記述します。

Private Sub Workbook_Open()

    Call AddMenu_SheetSeparate

End Sub

これを「Excelアドイン」(.xlam)形式で保存して、「ファイル」→「オプション」→「アドイン」→「管理」から「Excelアドイン」を選択して「設定」をクリック→「アドイン」ダイアログで「参照」から、先ほど保存したxlamファイルを追加して、以降開くすべてのExcelファイルに対して有効にする、って感じの使い方になるかと思います。

参考サイト

Office TANAKA - Excel VBA Tips[右クリックメニューに追加]
Office TANAKA - Excel VBA Tips[選択されたシートの操作]
VBAをEXCEL2007, 2010, 2013の32/64 bitの全てに対応させるにはどうすれば良いのか？解決！ - われこわれこ
 Office TANAKA - Excel VBA講座：シートの操作[コピー/移動する]
動作確認環境

Excel2016 16.0.7571.7063 64bit

Excel2016 : 選択したシートを新しいブックとして独立させる

コンテキストメニューからコマンド選択一発

コピーと移動を起動し分ける

選択したシートをコピーまたは移動する

ブックの後始末をする

まとめ

0 件のコメント :

コメントを投稿

人気記事

カテゴリー

ブログアーカイブ

Excel2016 : 選択したシートを新しいブックとして独立させる

コンテキストメニューからコマンド選択一発

コピーと移動を起動し分ける

選択したシートをコピーまたは移動する

ブックの後始末をする

まとめ

この記事をシェアする

0 件のコメント :

コメントを投稿

人気記事

カテゴリー

ブログアーカイブ