Copy Cell Above or Below

'Leverage & Lean "Less Clicks, More Results"
Sub CopyCellAboveBelow()
' Means variable is in use
Dim AboveorBelow As String '
Dim BelowCounter As Integer '
Dim Column As Integer '
Dim LastColumn As Integer '
Dim LastRow As Integer '
Dim Row As Integer '
 
On Error GoTo LeverageLean

'Determine if you want to copy the cell from Above or Below
AboveorBelow = InputBox("Do you want to copy the cell from Above or Below?" & vbNewLine & _
         "1. Copy Cell Above" & vbNewLine & _
         "2. Copy Cell Below")

'AboveorBelow = 1 'Default to copy cell from Above
'AboveorBelow = 2 'Default to copy cell from Below

If AboveorBelow = "" Then
Exit Sub
ElseIf AboveorBelow <> 1 And AboveorBelow <> 2 Then
MsgBox ("Please select a valid response 1 or 2.")
Exit Sub
End If
 
Row = 1
Column = 1
LastRow = Cells(Rows.Count, 1).End(xlUp).Row 'Identify Last Row on worksheet
LastColumn = Cells(Row, Columns.Count).End(xlToLeft).Column 'Identify Last Column on worksheet

Do Until Row > LastRow
Do Until Column > LastColumn
If Cells(Row, Column).Value = "" Then 'If Cell is Blank determine what cell to copy
If AboveorBelow = 1 Then 'Copy Cell Above
If Cells(Row - 1, Column).Value <> "" Then
Cells(Row, Column).Value = Cells(Row - 1, Column).Value
End If
ElseIf AboveorBelow = 2 Then 'Copy Cell Below
BelowCounter = 1
Do Until Cells(Row, Column).Value <> ""
If Cells(Row + BelowCounter, Column).Value <> "" Then
Cells(Row, Column).Value = Cells(Row + BelowCounter, Column).Value
End If
BelowCounter = BelowCounter + 1
Loop
End If
End If
Column = Column + 1
Loop
Column = 1
Row = Row + 1
Loop

Range("A1").Select

MsgBox ("Copy Cell from Above or Below is complete!  Stay Awesome!")
Exit Sub

LeverageLean:
MsgBox ("Something went wrong.  Don't hesitate to email me: brentschneider@leveragelean.com")

End Sub
'Stay Awesome