エクセルVBAでの処理をエクセルVBAで複数回のアンドゥ・リドゥ(元に戻すとやり直し)を書いてみた、その2

前回

gogowaten.hatenablog.com

の続き、より強引に危険になった

今度はシートをコピペしてアンドゥ・リドゥ(元に戻すとやり直し)を

できるようにしてみた

 

アンドゥ(元に戻す)回数の上限は3に指定してみた

動作の様子

http://www.geocities.jp/gogowaten/excel_animation12.gif

セルの値を使ってテキストボックスを作成するマクロを

アンドゥ・リドゥできるようにしてテストしているところ

最初は下半分は無視して、上半分だけ見たほうがわかりやすい

 

下半分がアンドゥ・リドゥ用のマクロがあるブックでバックアップ用になる裏方

上半分のBook1とBook3が普通のブック

同じブックでも異なるブックに対してもアンドゥ・リドゥできている

 

アンドゥ・リドゥの動作の考え方としては単純で

マクロを実行する直前にバックアップ用のブックにシートをコピーしておいて

アンドゥ・リドゥの時にはバックアップ用から元のブックに戻しているだけ

だから前回のをちょっと変えるだけだから1日でできそう！(意気揚々)

3日かかった！！！

 

 

ダウンロード先

ファイル名：マクロで行った処理をマクロでアンドゥ・リドゥ_シートをコピペ編.xlsm

OneDrive マクロで行った処理をマクロでアンドゥ・リドゥ_シートをコピペ編.xlsm

エクセル2007 - OneDrive(OneDrive)

 

マクロで行った処理をマクロでアンドゥ・リドゥ_シートをコピペ編.xlsm(ヤフーボックス)

 

 

 

使い方

ユーザーフォームのボタンに実行したいマクロを書いたり指定したりするときは

例えばCommandButton1のクリックイベントにかくと

---

Private Sub CommandButton1_Click()

’選択セルに0から10までのランダムな数値を記入するマクロ

    Dim r As Range

    Randomize

    For Each r In Selection

        r.Value = Int((10 - 0 + 1) * Rnd(10) - 0)

    Next

End Sub

---

こんなかんじになると思う

これをアンドゥ・リドゥできるようにするには

---

Private Sub CommandButton1_Click()

’選択セルに0から10までのランダムな数値を記入するマクロ

    Call myBefore前処理(ActiveSheet)

    Dim r As Range

    Randomize

    For Each r In Selection

        r.Value = Int((10 - 0 + 1) * Rnd(10) - 0)

    Next

    Call myAfter後処理

End Sub

---

こんなふうに赤字のところを書き加える

Call myBefore前処理(ActiveSheet)

このActiveSheetはどのシートを保存するかの指定だから

ActiveSheet以外のシートをアンドゥ・リドゥの対象にしたいときは

そのシートを指定する

 

要は

マクロの前にCall myBefore前処理(ActiveSheet)

マクロの後にCall myAfter後処理

を書けばいいだけ

あとは

1行目にある

Const wsCount As Long = 3

この数値3がアンドゥ・リドゥできる回数の上限になる

これを超えると古いものに上書きしていく

 

ユーザーフォームを表示するときは

UserFormUndoRedo.Show vbModeless

vbModelessを付けてシートやセルをクリックできるように表示する

これは標準モジュールに書く

---

Sub uf3Show()

    UserFormUndoRedo.Show vbModeless

End Sub

 

標準モジュールに書いてある

これを実行してユーザーフォームを表示する

 

ユーザーフォームを表示したところ

上にある数値は左が元に戻せる回数で右がやり直しできる回数

 

選択セルに乱数を記入するマクロが登録されたボタンを押す

 

乱数が記入されて元に戻せる回数が1増えた

テキストボックスボタンを押す

このボタンには選択範囲の値を記入したテキストボックスを

作成するマクロが登録してある

 

テキストボックスが作成されて元に戻せる回数が増えている

元に戻すボタンを押すと

 

テキストボックスを作成する前の状態に戻る

元に戻すの回数は1減って、やり直しが1回増える

やり直しボタンを押すと

 

元に戻す前の状態になった

元に戻す回数が1増えて、やり直し回数が1減った

元に戻すボタンを2回押すと

 

最初の状態に戻る、やり直し回数が2回になっている

ここから乱数ボタンを押すと

 

元に戻す回数が1増える

やり直し回数がリセットされて0になる

 

---

 

 

 

対応できないマクロ、エラーになるような状況

例えば

• ブックやシートを作成したり削除するマクロ
• 対象にするシートは1枚だけなので複数のシートに変更を加えるマクロ
• エクセル以外のファイルに何かするマクロ
• マクロで行った処理をマクロでアンドゥ・リドゥ_シートをコピペ編.xlsmにシート名がSave1とかSave21みたいなSaveと数字の組み合わせのシートがあるとユーザーフォームが表示できなくなる
• シート名：午後のアンドゥ・リドゥの左側はバックアップ用のシートなので、左側にシートを作成したり、左側のシートを削除したり変更したりすると正しく動作しなくなる

これ以外にもあると思うけど、こんなところ

 

 

対応できるマクロ、対応できそうなマクロ

• 1枚のシートの中で収まっているマクロ
• セルの書式や値を変更したりとかのマクロ

できるかどうか試す前にはファイルをバックアップをしてからの方がいい

 

 

ユーザーフォームのデザイン画面

このCommandButton1に普通にマクロを登録した状態が

↓

こんなかんじで

これをアンドゥ・リドゥ対応にするには

↓

 

こう

 

目的のマクロはこんなの

最小値から最大値の間の整数を選択セルに記入するマクロ

 

 

Const wsCount As Long = 3 '保存用シートの枚数(元に戻せる回数)、2以上を指定
Dim undoCount As Long '元に戻す用のカウント、0から3(0から保存シートの枚数)
Dim redoCount As Long 'やり直し用のカウント、0から3
Dim SaveSlot As Long '保存先シートの特定用、0から2(0から保存シートの枚数-1)
Dim ima As mySousa '今の操作の種類
Dim mae As mySousa '前回の操作の種類
Private Enum mySousa '操作の種類
    nasi = 0 '無し
    Sitei = 1 '指定
    iUndo = 2 '元に戻す
    iRedo = 3 'やり直し
End Enum

'保存するシート用
Dim mySheets() As Worksheet
Dim SheetName() As String
Dim SheetIndex() As Long 'シートの位置
Dim BookName() As String



'---------------------------------------------------------------
'////////////ここからユーザーフォームのイベント用////////////

'ユーザーフォーム起動するとき、いろいろ初期化
Private Sub UserForm_Initialize()
    Application.ScreenUpdating = False
    Dim ActSh As Worksheet: Set ActSh = ActiveSheet
    
    '色々初期化
    mae = nasi '前回の操作の種類を「無し」にする
    undoCount = 0
    redoCount = 0
    SaveSlot = 0
    ReDim SheetName(wsCount - 1)
    ReDim SheetIndex(wsCount - 1)
    ReDim BookName(wsCount - 1)
    Call urLabelラベル表示更新
'配列の初期化、ダミーシートを作って配列に入れる
    ReDim mySheets(wsCount - 1)
    Dim WS As Worksheet '最初の１枚目はBeforeで先頭に
    Set WS = ThisWorkbook.Sheets.Add(Before:=ThisWorkbook.Sheets(1))
    WS.Name = "Save" & 0
    Set mySheets(0) = WS
    
    '残りのシートはAfterで後に作成
    For i = 1 To wsCount - 1
        Set WS = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(i))
        WS.Name = "Save" & i
'        WS.Tab.ThemeColor = i + 5
        Set mySheets(i) = WS
    Next
       
    Me.CommandButton1.SetFocus
    Application.ScreenUpdating = True
    
    'ユーザーフォーム起動前にアクティブだったシートを表示
    ActSh.Activate
End Sub
'ユーザーフォーム終了時、保存用シートを削除
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error GoTo myError
    Application.DisplayAlerts = False
    oii = mySheets
    For i = 0 To wsCount - 1
        ore = mySheets(i).Name
        mySheets(i).Delete
    Next
    Application.DisplayAlerts = True
    Exit Sub
    
myError:
    Application.DisplayAlerts = True
    MsgBox Err.Description
End Sub
'シートを保存してから実行するマクロ用
Private Sub CommandButton1_Click()
    Call myBefore前処理(ActiveSheet)
    
    '目的のマクロ
    Call myRand選択範囲に乱数(10, 0)
    
    Call myAfter後処理
End Sub
Private Sub CommandButton2_Click()
'マクロ実行ボタン
    Call myBefore前処理(ActiveSheet)
    '↑のActiveSheet以外をバックアップするときはそのシートを指定する

    'ここに実行したいマクロを書く
    'Application.Run "PERSONAL.XLSB!セルの値でテキストボックスランダム色"
    Call セルの値でテキストボックスランダム色
    
    
    Call myAfter後処理
    
End Sub

'リドゥ
Private Sub CommandButtonRedo_Click()
    If redoCount = 0 Then Exit Sub
    
    ima = iRedo
    Call GetSaveSlot保存場所の決定
    Call UandRアンドゥリドゥの処理
    undoCount = undoCount + 1
    redoCount = redoCount - 1
    Call urLabelラベル表示更新
    mae = iRedo
End Sub
'アンドゥ
Private Sub CommandButtonUndo_Click()
    If undoCount = 0 Then Exit Sub
    
    ima = iUndo
    Call GetSaveSlot保存場所の決定
    Call UandRアンドゥリドゥの処理
    undoCount = undoCount - 1
    redoCount = redoCount + 1
    Call urLabelラベル表示更新
    mae = iUndo
End Sub

'////////////ここまでユーザーフォームのイベント用////////////
'---------------------------------------------------------------


'---------------------------------------------------------------
'////////////ここからシートのバックアップとリストア////////////

Sub urLabelラベル表示更新()
    Me.LabelRedoCount = redoCount
    Me.LabelUndoCount = undoCount
End Sub

Sub GetSaveSlot保存場所の決定()
    '今の操作と前回の操作からセーブする場所(シート)を決定する
    '場所(シート)は数値で管理0から数える、最大保存数が3なら0、1、2
    '0から使っていく、最大保存数を超えたら一番古いものに上書きしていく(012012012…)
    '今の操作と前回の操作が両方共アンドゥの時はカウントを戻す
    '今の操作と前回の操作のどちらかがアンドゥの時はカウントをそのままにする
    '最初の操作の時もそのまま
    'それ以外の時はカウント(場所)を進める(普通の操作やリドゥの時)
    
    '両方共アンドゥなら-1
    If ima = iUndo And mae = iUndo Then
        If SaveSlot = 0 Then
            SaveSlot = wsCount - 1
        Else
            SaveSlot = SaveSlot - 1
        End If
    'どちらかがアンドゥなら変化なし
    ElseIf ima = iUndo Or mae = iUndo Then
    '最初の操作だった
    ElseIf mae = nasi Then '一番最初なら0
        SaveSlot = 0
    'それ以外なら+1、最大数を超えていたら0
    ElseIf SaveSlot < wsCount - 1 Then
        SaveSlot = SaveSlot + 1
    ElseIf SaveSlot >= wsCount - 1 Then
        SaveSlot = 0
    End If
    
End Sub

Sub myBefore前処理(myWS As Worksheet)
    On Error GoTo myError
    Application.DisplayAlerts = False
    
    ima = Sitei
    Dim newSheet As Worksheet
    Call GetSaveSlot保存場所の決定
'バックアップ開始
    SheetName(SaveSlot) = myWS.Name 'シート名を記録
    SheetIndex(SaveSlot) = myWS.Index 'シートの位置を記録
    BookName(SaveSlot) = myWS.Parent.Name 'ブック名を記録、Parent.まで打つとエラー音が鳴る
    '一番古い保存シート削除
    ThisWorkbook.Sheets(SaveSlot + 1).Delete
    
    myWS.Copy Before:=ThisWorkbook.Sheets(SaveSlot + 1) 'シートをスロットの位置にコピー
    'コピー先に同じシート名があるとエクセルが自動でシート名の末尾に（２）とか連番を付ける
    
    Set mySheets(SaveSlot) = ThisWorkbook.Sheets(SaveSlot + 1) '複製したシートを配列に追加
    
    myWS.Activate
    Application.DisplayAlerts = True
    Exit Sub
    
myError:
    Application.DisplayAlerts = True
    MsgBox "何かのエラー発生" & Err.Description
End Sub
Sub myAfter後処理()
    If undoCount < wsCount Then
        undoCount = undoCount + 1
    End If
    redoCount = 0
    Call urLabelラベル表示更新 'ラベル表示更新
    mae = Sitei
End Sub
Private Sub UandRアンドゥリドゥの処理()
'変数に入れたシートはMoveすると変数が空になる
'保存先とリストア先が同じブックだとアンドゥ・リドゥの時にシート名の衝突が起こる
    Dim Sc As Long
    Dim motoBook As Workbook
    Dim myIndex As Long: myIndex = SheetIndex(SaveSlot) '元のシートの順番位置
    Dim motoSheet As Worksheet
    Set motoBook = Workbooks(BookName(SaveSlot)) '保存シートが有るブック
    Set motoSheet = motoBook.Sheets(myIndex) '保存するシート
    Application.ScreenUpdating = False
    
    
    '保存
    If motoBook.Name <> ThisWorkbook.Name Then
    '保存用ブックとマクロを実行するブックが違うとき
        motoSheet.Move Before:=ThisWorkbook.Sheets(SaveSlot + 1) '移動(保存)
        'リストア
        '移動でmySheet(SaveSlot)は空になる
        If myIndex > motoBook.Sheets.Count Then
            Sc = motoBook.Sheets.Count
            mySheets(SaveSlot).Move After:=motoBook.Sheets(Sc) '移動
        Else
            mySheets(SaveSlot).Move Before:=motoBook.Sheets(myIndex) '移動
        End If
    Else
    '保存用ブックとマクロを実行するブックが同じときは
    '名前の衝突を避けるために、移動ではなくコピーしてから削除する
    On Error GoTo myError
        Application.DisplayAlerts = False
        'コピーだと衝突しない名前に自動で変わる
        motoSheet.Copy Before:=ThisWorkbook.Sheets(SaveSlot + 1)
        motoSheet.Delete 'コピーしたからコピー元を削除
        Application.DisplayAlerts = True
        
        'リストア
        '移動でmySheet(SaveSlot)は空になる
        If myIndex >= motoBook.Sheets.Count Then
            Sc = motoBook.Sheets.Count
            mySheets(SaveSlot).Move After:=motoBook.Sheets(Sc) '移動
        Else
            mySheets(SaveSlot).Move Before:=motoBook.Sheets(myIndex) '移動
        End If
    End If
    

    motoBook.Sheets(myIndex).Name = SheetName(SaveSlot) '名前を元に戻す
    
    '保存
    '空になったmySheet(SaveSlot)に保存
    Set mySheets(SaveSlot) = ThisWorkbook.Sheets(SaveSlot + 1)
    
    Application.ScreenUpdating = True
    Exit Sub
    
myError:
    Application.DisplayAlerts = True
End Sub
'////////////ここまでシートのバックアップとリストア////////////
'---------------------------------------------------------------

'---------------------------------------------------------------
'////////////ここから適当な実行したいマクロ////////////
Sub myRand選択範囲に乱数(最大値 As Long, 最小値 As Long)
    Dim r As Range
    Randomize
    For Each r In Selection
        r.Value = Int((最大値 - 最小値 + 1) * Rnd(最大値) - 最小値)
    Next
End Sub
Sub セルの値でテキストボックスランダム色()
'2015/05/30
Dim c As Range
Dim myRng As Range
Dim myTxt As String
Dim myShar As Shape
Randomize

Set myRng = Selection
  For Each c In myRng
    myTxt = c.Value
    If myTxt <> "" Then
        Set myShar = ActiveSheet.Shapes.AddShape( _
            msoShapeRoundedRectangle, c.Left, c.Top, c.Width, c.Height)
        With myShar.Fill
          .Visible = msoTrue
          .ForeColor.RGB = Int((16777215 - 0 + 1) * Rnd(16777215) - 0)
        End With
        myShar.Line.Visible = msoFalse '枠なし
        With myShar.TextFrame
          .Characters.Text = myTxt
          .HorizontalAlignment = xlCenter
          .VerticalAlignment = xlCenter
          .AutoSize = False 'Trueでテキストの合わせてサイズを自動調整
        End With
        With myShar.TextEffect
            .FontName = c.Font.Name
            .FontSize = c.Font.Size
        End With
    End If
  Next
End Sub

 

 

シートのブック間の移動やコピーのマクロって書いたことなかった

変数に入れたシートを移動させると変数から飛び出して変数が空になるとか

予想外だったｗ

 

今まではエラーが出ても無視して突き進む

On Error Resume Next

こればかり書いていたけど

シートを削除しようとするときに出るダイアログボックスを非表示にする

Application.DisplayAlerts = False

これが放置されたままになる状況があって、それはかなり良くないと思って

エラーの対処も少し書いてみた

参照したところは

Office TANAKA - Excel VBA Tips[エラーに負けない]

http://officetanaka.net/excel/vba/tips/tips104.htm

 

 

続きは翌日

gogowaten.hatenablog.com