これをプログラムで行う。
Sub ResetLastCell()
' シートの xlLastCell の位置を再調整する
' 削除範囲にデータがあっても確認せずに削除するので、注意。
'【 使い方 】LastCell にしたいセルを選択して呼び出す。実行後、ブックを開き直すこと。
Dim wCell As Range, wRet As Integer
Dim wNewRow As Long, wNewCol As Long, wCurRow As Long, wCurCol As Long
Set wCell = ActiveCell
wRet = MsgBox( _
wCell.Address + "を LastCell にします。" + vbCrLf + vbCrLf + _
"他のセルを指定するには「No」を押してください。", _
vbYesNoCancel, "LastCell の位置を再調")
If (wRet = vbCancel) Then GoTo ResetLastCellExit
If (wRet = vbNo) Then
Set wCell = Application.InputBox(Prompt:="新しい LastCell を選択してください。", Type:=8)
If (wCell Is Nothing) Then GoTo ResetLastCellExit
On Error GoTo 0
End If
wCell.Parent.Activate
wNewRow = wCell.Row + 1: wNewCol = wCell.Column + 1
Set wCell = wCell.SpecialCells(xlLastCell)
wCurRow = wCell.Row: wCurCol = wCell.Column
' 削除による参照先エラーを避けるため、Cells で指定する。
If (wCurRow > wNewRow) Then ' 行を調整
Range(Cells(wCurRow, wCurCol), Cells(wCurRow, wCurCol)).EntireRow.Cut Destination:=Range(Cells(wNewRow, wNewCol), Cells(wNewRow, wNewCol)).EntireRow
Range(Cells(wNewRow, wNewCol), Cells(wCurRow, wCurCol)).EntireRow.Delete Shift:=xlUp
End If
If (wCurCol > wNewCol) Then ' 列を調整
Range(Cells(wCurRow, wCurCol), Cells(wCurRow, wCurCol)).EntireColumn.Cut Destination:=Range(Cells(wNewRow, wNewCol), Cells(wNewRow, wNewCol)).EntireColumn
Range(Cells(wCurRow, wCurCol), Cells(wNewRow, wNewCol)).EntireColumn.Delete Shift:=xlLeft
End If
MsgBox "ブックを保存し、開き直してください。", vbOKOnly
ResetLastCellExit:
End Sub
0 件のコメント:
コメントを投稿