セルに値を入力すると同時に、値を自動で上に詰める仕組みの実現方法について紹介していきます。
また、今回の仕組みでは、表の途中の値を削除した際にも、値が自動で上に詰められます。
※こちらで開発したファイルは記事の最後にて配布しています。
1. 開発準備
こちらでは、以下のような「氏名」を入力する１列の表を活用します。
そして、「この表に新規で値を入力した時や、値を削除した時に、表の値を上に詰める」という仕組みを実装していきます。
そのように、該当するシートのセルを編集すると同時に処理を自動で実行するには、「シートモジュール」の「イベントプロシージャ」を活用します。
シートモジュールは、該当するシートのタブ上で右クリックし、[コードの表示]を選択することで表示することができます。
選択すると、以下のエディタ画面（VBE）が表示されます。
また、該当するシートのシートモジュールが表示された状態になります。
「Option Explicit」は、VBEの設定内容次第では表示されません。「Option Explicit」についての解説はこちらでは省略します。
次に、該当するシートのセルを編集すると同時に処理が実行される特殊なプロシージャ（イベントプロシージャ）を用意する必要があります。
そのためには、シートモジュールの左上のリストから「Worksheet」を選択します。
「Worksheet」を選択すると、自動で「Worksheet_SelectionChange」というプロシージャが表示されます。
このプロシージャは、該当するシート上のいずれかのセルが選択されると同時に処理が実行されるイベントプロシージャになります。
ただ、今回使用するイベントプロシージャは、セルを編集すると同時に処理が実行されるものになります。
そのため、右上のリストから「Change」を選択します。
表示された「Worksheet_Change」というプロシージャを活用します。
「Worksheet_SelectionChange」というプロシージャに関しては削除して問題ないです。
2. コードの記述
以下のコードを記述します。
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge = 1 And _
Target.Row >= 3 And _
Target.Column = 2 Then
Application.EnableEvents = False
Dim lRow As Long
lRow = Cells(Rows.Count, "B").End(xlUp).Row
On Error Resume Next
Range("B3", Cells(lRow, "B")). _
SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
On Error GoTo 0
Application.EnableEvents = True
End If
End Subでは、コードについて解説していきます。
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge = 1 And _
Target.Row >= 3 And _
Target.Column = 2 Then
'省略
End If
End Sub「Worksheet_Change」というプロシージャの引数の「Target」に、編集されたセルの情報が渡されるため、そのセルの情報から、表の対象のセルが編集されたかどうかを確認しています。
こちらでは、編集されたセルが１つ（Target.CountLarge = 1）で、行番号が３以上（Target.Row >= 3）、尚且つ、列番号が２（Target.Column = 2）であることを確認しています。
この条件は「表の範囲内の単体のセルが編集された時」という条件になります。
この条件を満たした場合に、Ifの中の処理を実行します。
Application.EnableEvents = False
'省略
Application.EnableEvents = True今回の処理の内容は、セルの値を上に詰めるという内容です。
Ifの条件範囲内のセルを処理の中で操作するため、「Worksheet_Change」の処理が再度実行されないようイベントを無効にする処理（Application.EnableEvents = False）を記述しています。
処理の最後には、イベントの無効化を解除する処理（Application.EnableEvents = True）を記述しています。
Dim lRow As Long
lRow = Cells(Rows.Count, "B").End(xlUp).Row
On Error Resume Next
Range("B3", Cells(lRow, "B")). _
SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
On Error GoTo 0表を上に詰める方法として、こちらでは表の中の空白セルを削除して上方向にシフトするという方法で実装しています。
まずは、表の値が入力されている末尾のセルの行番号を変数「lRow」に格納しています。
B列の最終行のセル（Cells(Rows.Count, “B”)）からCtrlキーとカーソルキーの上を押して移動（End(xlUp)）した先のセルの行番号（Row）を末尾の行番号として取得しています。
次に、表の先頭のセルB3から末尾のセル（Cells(lRow, “B”)）の範囲内の空白セル（SpecialCells(xlCellTypeBlanks)）を削除（Delete）して上方向にシフト（Shift:=xlUp）しています。
ただ、この処理の内容ですと、空白セルが存在しない時にエラーになってしまうので、エラー対策をしています。
具体的には、エラーになった場合は対象の処理をスキップする（On Error Resume Next ～ On Error GoTo 0）という内容を記述しています。
3. 完成
以上の内容で実現できます。
表の中のセルを編集すると同時に、表の中の空白セルが削除され、値が上に詰められます。
▼サンプルファイル▼
