Excel VBA copy/Paste loop for every fourth cell

Question

I'm looking to make a macro that copies every 4th cell in Column B (Starting at B3) and then pastes it in Column A (the paste is 4 cells in a row. So the value in B3 will paste into A3,A4,A5,A6. Then the macro should copy B7 and paste it in A7,A8,A9,A10...etc

The cell B3 that I copy is a merged cell (B3-B6).

Ultimately I'm trying to get to a point where I can filter a list by date, but when filtering by merged cells it causes problems.

I added an image to show the first two iterations

I can get the initial copy and paste down, but when it comes to making the loop for each of these I start getting confused

Answer 1

• MergeArea.Cells.Count returns the cell count of the merged area (Range).

• Offset(, -1) get the cell of col A in the same row.

Microsoft documentation:

Range.Offset property (Excel)

Range.Resize property (Excel)

Range.MergeArea property (Excel)

Option Explicit
Sub Demo()
    Dim i As Long, lastRow As Long
    Const CELL_CNT = 4
    With Sheets("Sheet1") ' modify as needed
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        For i = 3 To lastRow Step CELL_CNT
            With .Cells(i, "B")
                .Offset(, -1).Resize(.MergeArea.Cells.Count).Value = .Value
                ' OR
                ' .Offset(, -1).Resize(CELL_CNT).Value = .Value
            End With
        Next i
    End With
End Sub

---

• If the cell count in the merged area is different, the following code can handle this scenario.
• Of course, it solves your question too.

Option Explicit
Sub Demo()
    Dim c As Range
    Const START_ROW = 3
    With Sheets("Sheet1") ' modify as needed
        Set c = .Cells(START_ROW, "B")
        Do While IsDate(c.Value)
            c.Offset(, -1).Resize(c.MergeArea.Cells.Count).Value = c.Value
            Set c = c.Offset(1)
        Loop
    End With
End Sub

Answer 2

Set ws = ActiveSheet
LastRow = ws.Cells.Find(What:="*", After:=ws.Range("a1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
StartRow = 3
SizeOfMergeCell = 4

For i = StartRow To LastRow Step SizeOfMergeCell
    For j = 0 To SizeOfMergeCell - 1
        ws.Cells(i + j, "A").Value = ws.Cells(i, "B").Value
    Next j
Next i