Copy data cell down or up - vba

Question

I am a noob in vba. However, I would like to implement the following use case to make my cooperate life a lot of easier.
I have the following data:
I would like to copy the first row down until I hit a filled field, the second row also down until I hit a filled field, the third row up and down and the 4th row up.
This is how I would like to have my result sheet should look like.
Any recommendation how to implement this use case in vba?
I appreciate your replies!

Answer 1

can you please try this one? This routine is assuming column G as main start point and checks if column A,B,C,D is empty or not in the same row and fill it up accordingly.
Sub ASD()
Dim lastRow As Long
lastRow = Range("G" & Rows.Count).End(xlUp).Row
For Each c In Range("G:G")
If c.Value <> "" Then
If c.Offset(0, -3).Value = "" Then
c.Offset(0, -3).Value = c.Offset(0, -3).End(xlDown).Value
End If
If c.Offset(0, -4).Value = "" Then
c.Offset(0, -4).Value = c.Offset(0, -4).End(xlUp).Value
End If
If c.Offset(0, -5).Value = "" Then
c.Offset(0, -5).Value = c.Offset(0, -5).End(xlUp).Value
End If
If c.Offset(0, -6).Value = "" Then
c.Offset(0, -6).Value = c.Offset(0, -6).End(xlUp).Value
End If
End If
Next c
End Sub
Only problem is it do not do anything if the reference cell is empty in the column G. I think you don't need that anyway.

Answer 2

Hope this help.
It will run on your current selection
Copy the whole code into a module, run the fill_down() to fill down, fill_up() to fill up.
'======================
'******Filling*********
'======================
Sub fill_up()
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[1]C"
End Sub
Sub fill_down()
Call copy_last(Selection)
Call filling
End Sub
Function copy_last(r As range)
Dim arr() As Variant
Dim x As Double
Dim arr_size As Double
arr = r
arr_size = UBound(arr, 1)
For x = arr_size To 1 Step -1
If Not isempty(arr(x, 1)) Then
Exit For
End If
Next x
r(r.Row, 1) = arr(x, 1)
End Function
Function filling()
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
End Function
'=======================
'******End filling******
'=======================