【Excel VBA】空白セルを含む列を入れ替える

前の記事で空白セルを含む列を選択することができたので、2つの列を入れ替えるマクロもアップグレードしてみる。

早速コード

Public Sub ExchangeColumns()
    Dim userSelectCell As Range
    Dim tgtRange_1 As Range
    Dim tgtRange_2 As Range
    Dim tgtValue_1 As Variant
    Dim tgtValue_2 As Variant
    
    '現在選択されているセルの列をRangeオブジェクトに代入
    With Selection
        Set tgtRange_1 = Range(.End(xlUp), Cells(Rows.Count, .Column).End(xlUp))
    End With
    
    ' 入れ替える列をインプットボックスで聞く
    ' このときマウスで入れ替え列のどれかのセルをクリックするだけでよい
    ' キャンセルが押されると何もせずに終了される
    On Error GoTo ExchangeColumns_Error
    Set userSelectCell = Application.InputBox( _
        Prompt:="1st Column : " & tgtRange_1.Address & vbCrLf & "Select 2nd Column", _
        Title:="Click And Select Any Cell(s)", _
        Type:=8)
    On Error GoTo 0
    
    ' 入れ替え列をオブジェクトに代入
    With userSelectCell
        Set tgtRange_2 = Range(.End(xlUp), Cells(Rows.Count, .Column).End(xlUp))
    End With
    
    ' それぞれの列の値を記憶
    tgtValue_1 = tgtRange_1
    tgtValue_2 = tgtRange_2
    
    ' それぞれの列の値を入れ替えてオブジェクトに代入
    Application.ScreenUpdating = False
    tgtRange_1 = tgtValue_2
    tgtRange_2 = tgtValue_1
    Application.ScreenUpdating = True
    
ExchangeColumns_Error:
    ' オブジェクトを破棄
    Set userSelectCell = Nothing
    Set tgtRange_1 = Nothing
    Set tgtRange_2 = Nothing
End Sub

以前のコードのRangeをオブジェクト変数に代入する部分を変更しただけである。

これで列中に空白セルが存在してもきっちり列の最終行を把握して列ごと入れ替えてくれる。

ただしこれも前の記事で最後に触れたように、入れ替える列の片方の列の最終行が空白セルであるような場合は、2つの列のセルの個数が合わなくなって合わない分のセルにエラー値が表示される。2つの列の双方の最後のセルは同じ行数でないといけない。