詰める

某サイトで「ExcelのWorksheetでコードが空の行を詰めたいんだけどどうしたらいいの」という質問を見つけました。
かわいそうに誰も回答してくれなくて、唯一のコメントは「VBA勉強すれば？」という冷たい内容だったのですが、ひまだしおもしろそうなので、作ってみました。

空の行を詰めるサンプルです。

Public Sub Sample_Tsumeru()
On Error GoTo ERR_SEC
Dim bRet	As Boolean
Dim sMsg	As String
Dim sRange	As String
Dim objSheet As Worksheet
Dim vArray	As Variant
Dim lRowMax	As Long
Dim i As Long, j As Long

	'--- 初期値セット ---
	bRet = False
	'--- シートへの参照を取得する ---
	Set objSheet = ThisWorkbook.Worksheets("Sheet3")
	'--- 詰める ---
	With objSheet
		lRowMax = .Cells.SpecialCells(xlCellTypeLastCell).Row
		For i = 1 To .Cells.SpecialCells(xlCellTypeLastCell).Column
			For j = 1 To lRowMax - 1
				If Len(.Cells(j, i).Value) <= 0 Then
					'--- 空白が見つかったセルの次の行から最終行までの値を配列に格納する --
					sRange = .Range(.Cells(j + 1, i), .Cells(lRowMax, i)).Address(RowAbsolute:=False, ColumnAbsolute:=False)
					vArray = .Range(sRange)
					'--- 値を取得したセルの数式と値をクリアする ---
					.Range(sRange).ClearContents
					'--- 貼り付ける ---
					sRange = .Range(.Cells(j, i), .Cells(lRowMax - 1, i)).Address(RowAbsolute:=False, ColumnAbsolute:=False)
					.Range(sRange) = vArray
				End If
			Next j
		Next i
	End With
	
	'--- 正常終了 ---
	bRet = True

EXIT_SEC:
On Error Resume Next

	'--- 参照を解放 ---
	Set objSheet = Nothing
	If bRet Then
		MsgBox "正常終了"
	ElseIf Len(sMsg) > 0 Then
		MsgBox sMsg
	Else
		MsgBox "!!! ERROR !!!"
	End If
	
	Exit Sub

ERR_SEC:
	sMsg = "予期せぬエラーが発生しました。" & vbCrLf & _
			"プロシージャ名： Sample_Tsumeru" & vbCrLf & _
			"エラー番号：" & Err.Number & vbCrLf & _
			"エラー内容：" & Err.Description
	GoTo EXIT_SEC
End Sub

これ以上発展性のないソースですが。。。以上、詰めるサンプルでした。