VBA to copy a specific cell and paste into adjacent column

Question

I am trying to create VBA code that copies and pastes data from a specific cell into a series of cells until its empty. I do not have great experience with VBA and so I am struggling to create such a code.

I would like to create a code that loops for an entire set of data so for example B2 cell would need to copied in cell from A5 until A9. Then, B12 would be copied from A15 until A19.

And all the way down until the list was completed[Copied Data]. Data Before Copying New Result Expected Data copy into different column

Any help would be appreciated.

Answer 1

A slightly different approach. Is dynamic and you can increase or decrease the range in Columna A (yellow part)

---

VBA Code:

Sub CopyPaste()

Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")     'Sheet name
Dim lrow As Long
Dim cl As Variant
Dim myRange As Range
Dim currentRow As Long
Dim currentRowValue As String
Dim currRow As Long

lrow = ws.Cells(Rows.Count, 2).End(xlUp).Row     'Find last row in Sheet1
Set myRange = ws.Range(ws.Cells(1, 2), ws.Cells(lrow, 2)) 'Range you want to loop through in Column B, from row 1 to last row

For Each cl In myRange
    Debug.Print cl
    If cl.Value <> "" And cl.Value <> "Day Date" And Not IsDate(cl.Value) Then 'Ignore empty cells, Cells with the word "Day Date" or if the cells contain a date
        For currentRow = cl.Row + 2 To cl.Row + 10
            currentRowValue = Cells(currentRow, 2).Value
            If IsEmpty(currentRowValue) Or currentRowValue = "" Then 'Checks for empty rows in the area below
                currRow = Cells(currentRow, 2).Row
                Exit For
            End If
        Next
        Range(Cells(cl.Row, 1).Offset(3, 0), Cells(currRow - 1, 1)) = Cells(cl.Row, 2) 'Set current value in Column B to the adjacent range (Column A). Offset(3, 0) - this part sets the first cell in the range. Increase "+7" to make range larger
    End If
Next cl                                          'Next value to loop

End Sub

Result:

---

EDIT: To copy to another sheet.

Sub copyNonBlankData()
Dim erow As Long, lastrow As Long, i As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Sheet name
Dim ws2 As Worksheet
Set ws2 = ActiveWorkbook.Worksheets("Sheet2") 'Sheet name

lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
erow = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

For i = 4 To lastrow
    If ws.Cells(i, 1) <> "" Then
        ws.Range(ws.Cells(i, 1), ws.Cells(i, 1)).Copy 'Copy Serial number
        ws2.Range(ws2.Cells(erow, 1), ws2.Cells(erow, 1)).PasteSpecial xlPasteAll 'Paste serial
        ws.Range(ws.Cells(i, 2), ws.Cells(i, 2)).Copy 'Copy date
        ws2.Range(ws2.Cells(erow, 3), ws2.Cells(erow, 3)).PasteSpecial xlPasteAll 'Paste serial
        ws.Range(ws.Cells(i, 3), ws.Cells(i, 4)).Copy 'Copy values
        ws2.Range(ws2.Cells(erow, 5), ws2.Cells(erow, 6)).PasteSpecial xlPasteAll 'Paste values
        ws2.Range(ws2.Cells(erow, 4), ws2.Cells(erow, 4)).Interior.Color = RGB(255, 242, 204) 'Fill Colour in 3rd column
        ws2.Range(ws2.Cells(erow, 2), ws2.Cells(erow, 2)).Borders(xlEdgeBottom).LineStyle = xlContinuous 'Add borders to 2nd column
        ws2.Range(ws2.Cells(erow, 4), ws2.Cells(erow, 4)).Borders(xlEdgeBottom).LineStyle = xlContinuous 'Add borders to 4th column
        erow = erow + 1
    End If
Next i
Application.CutCopyMode = False
End Sub

More efficient code

Sub copyNonBlankData()
Dim erow As Long, lastrow As Long, i As Long
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1") 'Copy From - Sheet name
Dim ws2 As Worksheet
Set ws2 = ActiveWorkbook.Worksheets("Sheet2") 'Paste To - Sheet name

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False

lastrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
erow = ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

For i = 4 To lastrow
    If ws.Cells(i, 1) <> "" Then
        With ws.Range(ws.Cells(i, 1), ws.Cells(i, 1))
            ws2.Range(ws2.Cells(erow, 1), ws2.Cells(erow, 1)).Value = .Value
        End With
        With ws.Range(ws.Cells(i, 2), ws.Cells(i, 2))
            ws2.Range(ws2.Cells(erow, 3), ws2.Cells(erow, 3)).Value = .Value
        End With
        With ws.Range(ws.Cells(i, 3), ws.Cells(i, 4))
            ws2.Range(ws2.Cells(erow, 5), ws2.Cells(erow, 6)).Value = .Value
            ws2.Range(ws2.Cells(erow, 3), ws2.Cells(erow, 7)).Interior.Color = RGB(255, 242, 204) 'Fill Colour in 3rd column
            ws2.Range(ws2.Cells(erow, 1), ws2.Cells(erow, 7)).Borders.LineStyle = xlContinuous 'Add borders to 2nd column
        End With
        erow = erow + 1
    End If
Next i
Application.CutCopyMode = False

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True

End Sub

Answer 2

My code is bad and may be kind of slow. I have not tested it.

Written on mobile, sorry for bad formatting.

Option Explicit

Sub FillDown()

' I assume Sheet1, change it to whatever your sheet's name is
With Thisworkbook.worksheets("Sheet1")

application.screenupdating = false
application.calculation = xlcalculationmanual

Dim lastRow as long
lastRow = .cells(.rows.count, "B").end(xlup).row

Dim rowIndex as long

For rowIndex = 1 to lastRow

If .cells(rowIndex, "B").value2 = "Day Date" then

.cells(rowIndex, "B").offset(3, -1).resize(5,1).value2 = .cells(rowIndex-2, "B").value2

rowIndex = rowIndex + 5
End if

Next rowIndex

End with

application.screenupdating = true
application.calculation = xlcalculationautomatic

End sub