空白セルを消去上詰め、段落分け、列を挿入

Sub 空白行を上詰め()

    Selection.SpecialCells(xlCellTypeBlanks).Select

    Selection.Delete Shift:=xlUp

End Sub

 

Sub 整理()
Selection.CurrentRegion.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Columns("B:C").Insert
Dim i As Long
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
If Left(Cells(i, 1), 2) = " " Then
Cells(i, 3) = Cells(i, 1)
Cells(i, 1).Clear
ElseIf Left(Cells(i, 1), 1) = " " Then
Cells(i, 2) = Cells(i, 1)
Cells(i, 1).Clear
End If
Next i
End Sub