VBA code: Copy Active Cell and Paste 2 cells/rows directly below

[mickyflash]

Hello All

I need a VBA code that copies the active cell, and pastes values 2 cells directly below the active cell. (skips a row). so if the active cell is A1, the target cell would be A3
This code works, until we hit cells that have been merged. The merged cells will always be the same size, and I am only pasting values but cant get it working without breaking the merged cell.

Does anyone have any ideas on a fix for this please?

Sub CopyAndPasteTwoCellsBelow()
    ' Copy the value from the active cell
    ActiveCell.Copy
    
    ' Move two cells down
    Dim targetCell As Range
    Set targetCell = ActiveCell.Offset(2, 0)
    
    ' Check if the destination cell is not empty
    If Not IsEmpty(targetCell.Value) Then
        ' Ask the user whether to overwrite the existing value
        Dim overwrite As VbMsgBoxResult
        overwrite = MsgBox("The destination cell is not empty. Do you want to overwrite?", vbYesNo + vbQuestion, "Overwrite Warning")
        
        ' Check the user's response
        If overwrite = vbNo Then
            Exit Sub ' Exit the sub if the user chooses not to overwrite
        End If
    End If

 

[Skyybot]

Are the Merged cells always the same number of cells Merged together?

 

[Skyybot]

Are the Merged cells always the same number of cells Merged together?

It doesn't matter. Yes, you will have to UnMerge and Merge the cells back.

 

[Skyybot]

Actually, I just tested your code and it's working fine for me. At what line is your code breaking?

Edit: You must be on the trailing end of the Merged cells. Then Post #3 is still correct.

 

[Skyybot]

Try this.

Sub CopyAndPasteTwoCellsBelow()
    ' Copy the value from the active cell
    'ActiveCell.Copy
    
    ' Move two cells down
    Dim targetCell As Range
    Set targetCell = MergeAddress(ActiveCell)
    
    ' Check if the destination cell is not empty
    If Not IsEmpty(targetCell.Value) Then
        ' Ask the user whether to overwrite the existing value
        Dim overwrite As VbMsgBoxResult
        overwrite = MsgBox("The destination cell is not empty. Do you want to overwrite?", vbYesNo + vbQuestion, "Overwrite Warning")
        
        ' Check the user's response
        If overwrite = vbNo Then
            Exit Sub ' Exit the sub if the user chooses not to overwrite
        End If
    End If
targetCell.Value = ActiveCell.Value
End Sub
Function MergeAddress(ByVal Target As Range)
Dim targetCell As Range, tAdd
Set targetCell = Target.Offset(2, 0)
If targetCell.MergeCells = True Then
    tAdd = Left(targetCell.MergeArea.Address, InStr(1, targetCell.MergeArea.Address, ":") - 1)
End If
Set MergeAddress = ActiveSheet.Range(tAdd)
End Function

 

[mickyflash]

Thank you so much this is working great