インストールレスプログラミング( ´ー`)

VBA , JavaScript , HTAなど 365アプリはインストール必要ですが、仕事に無いケースはほぼないから(・_・;)

Excel VBA セルの値だけを入れ替えるマクロ

さて,いつになったらパワーポイントのマクロに戻れるのか。

実務のほうがそのモードに入るまでもうちょいかかりそう。

どうも春から生活が変化しそうです。楽しみです。

さて,高等学校では4月になると時間割が作られます。

時間割作成ソフトというのがあるので,その機能である程度までは形にするんですが,どうしても最後のほうの書式は自分でカスタマイズしていきたいもの。

また,その時間割のデータをいろんな形に加工して利用するので,そこはExcelVBAの出番。

いろいろな書式が施されているうえで,値だけ入れ替えたいんだよね,というケースに頻繁に出会う仕事です。

その準備をしておこうと思いましたので,書式を変えずデータだけ入れ替える,というマクロを用意しました。

ある程度の大きさの連続範囲を入れ替えるということもよくやるので,そのイメージでコードを書いた。

あと,ApplicationオブジェクトのmacroOptionsでショートカットキーを設定する,というのも知りませんでしたので,そちらも使用。

うん,これは短いけど使えそうだ。

VBAコード(改善前)

Option Explicit
Sub SetShortcut()
    Application.MacroOptions Macro:="ReplaceValues", HasShortcutKey:=True, ShortcutKey:="r"
End Sub

Sub RemoveShortcut()
    Application.MacroOptions Macro:="ReplaceValues", HasShortcutKey:=True, ShortcutKey:=""
End Sub

Sub ReplaceValues()
    Dim SelectionRange As Range: Set SelectionRange = Selection

    If SelectionRange.Areas.Count <> 2 Then Exit Sub
    
    Dim ColumnsCount As Long, RowsCount As Long
    ColumnsCount = SelectionRange.Areas(1).Columns.Count
    RowsCount = SelectionRange.Areas(1).Rows.Count
    
    Union(SelectionRange.Areas(1), SelectionRange.Areas(2).Resize(RowsCount, ColumnsCount)).Select
    Set SelectionRange = Selection
    
    Dim tmp(): ReDim tmp(1 To 2, 1 To RowsCount, 1 To ColumnsCount)
    Dim i As Long, j As Long, k As Long
    
    For k = 1 To 2
        For i = 1 To RowsCount
            For j = 1 To ColumnsCount
                tmp(k, i, j) = SelectionRange.Areas(k).Value2(i, j)
            Next
        Next
    Next
    
    With SelectionRange.Areas(1)
        For i = 1 To RowsCount
            For j = 1 To ColumnsCount
                .Cells(i, j) = tmp(2, i, j)
            Next
        Next
    End With
    
    With SelectionRange.Areas(2)
        For i = 1 To RowsCount
            For j = 1 To ColumnsCount
                .Cells(i, j) = tmp(1, i, j)
            Next
        Next
    End With
End Sub

VBAコード(改善後)

追記になります。imihitoさんからのご指摘を適用してみました。

Option Explicit
Sub SetShortcut()
    Application.MacroOptions Macro:="ReplaceValues", HasShortcutKey:=True, ShortcutKey:="r"
End Sub

Sub RemoveShortcut()
    Application.MacroOptions Macro:="ReplaceValues", HasShortcutKey:=True, ShortcutKey:=""
End Sub

Sub ReplaceValues()
    Dim SelectionRange As Range: Set SelectionRange = Selection

    If SelectionRange.Areas.Count <> 2 Then Exit Sub
    
    Dim ColumnsCount As Long, RowsCount As Long
    ColumnsCount = SelectionRange.Areas(1).Columns.Count
    RowsCount = SelectionRange.Areas(1).Rows.Count
    
    Union(SelectionRange.Areas(1), SelectionRange.Areas(2).Resize(RowsCount, ColumnsCount)).Select
    Set SelectionRange = Selection
    
    Dim tmp
    
    With SelectionRange
        tmp = .Areas(1).Value2
        .Areas(1).Value2 = .Areas(2).Value2
        .Areas(2).Value2 = tmp
    End With
    
End Sub

めちゃくちゃ短くなり,しかもシンプルになりました。イイですね。すばらしい。。

使い方

使用法はいたってシンプル
まずSetShortCutマクロを一度実行をしておいてください。
この設定はブックに保存されるらしいので,一度設定すればこのブックを開くとショートカットはもう設定されたままになっています。

replaceなので ctrl+r に設定していますが,隣をコピーする,というショートカットを愛用している方はほかのショートカットにしてください。

解除方法としてRemoveShotrCutマクロを準備しています。

面白い仕組みですね。初めて知った内容でした。


ctr+rを押すと選択している範囲1と範囲2の値が入れ替わります。

危険でもありますが,利便性のために,範囲2の形は範囲1の形に強制的に合わせられます。

なので,範囲2は範囲2の左上のセルを指定するだけで十分です。

値を入れ替えているだけなので,もう一度ctrl+rを押すともとに戻せます(ΦωΦ)


一応数式を同じようにすることも簡単そうでした。Value2ではなくFormulaR1C1とかを取得して書かせるようにしたらたぶんできる。

でも,それは良し悪しで,値を入れ替えるというのがわたしの目的には適していたので今回は値の入れ替えをします。

コードの説明

    Application.MacroOptions Macro:="ReplaceValues", HasShortcutKey:=True, ShortcutKey:="r"
    Application.MacroOptions Macro:="ReplaceValues", HasShortcutKey:=True, ShortcutKey:=""

ショートカットの設定と,解除のところです。ctrl+shift+r を設定したい場合は ShortCutKey:="R"にすればよいそうです。

    Union(SelectionRange.Areas(1), SelectionRange.Areas(2).Resize(RowsCount, ColumnsCount)).Select
    Set SelectionRange = Selection

複数のセル範囲を得るためにUnionを使っています。
また,SelectionReangeを変化させたかったので,Setしなおしています。

    For k = 1 To 2
        For i = 1 To RowsCount
            For j = 1 To ColumnsCount
                tmp(k, i, j) = SelectionRange.Areas(k).Value2(i, j)
            Next
        Next
    Next

ここは無念でした。For Eachで書きたかった>< でも思いつかなかった。
そのこだわりは無意味だったので,素直に書きました。
離れた数か所のセルを選んでいるときは,それぞれはAreas(インデックス)に収められます。

そして,これも私はあまり使ったことなかったValue2プロパティ
f:id:chemiphys:20170325121115p:plain
値を二次元で格納してくれていましたので,今回利用させてもらいました。便利だなぁ。

ちなみに
f:id:chemiphys:20170325121217p:plain
FormulaR1C1も同じように格納されています。

今回は3次元の配列が便利だったので,tmpは3次元の配列です。

動作動画

f:id:chemiphys:20170325120205g:plain