Find value and copy the Range to another sheet with merged cells

Might be easiest to just unmerge the cells.

Sub UnMergeCells()
    Dim rng As Range
    Dim a As String
    Dim i As String
    Dim sh As Worksheet

    Set sh = ActiveSheet
    For Each rng In sh.UsedRange
        If rng.MergeCells Then
            rng.Orientation = xlHorizontal
            a = rng.MergeArea.Address
            i = rng
            rng.MergeCells = False
            Range(a) = i
        End If

    Next

End Sub

Here is the code for macro.
Value to be entered in B2 of Sheet "Copy".

Sub CopyData()

Dim LR As Long, X As Long, FstRo As Long, LastRo As Long
Dim Fstr As String
Dim Frng As Range

On Error GoTo Line1
Sheets("Packing").Activate

LR = Range("C" & Rows.Count).End(xlUp).Row

With Sheets("Copy")
Fstr = .Range("B2")
.Cells.Delete
.Cells.Interior.Pattern = xlNone
.Cells.Borders.LineStyle = xlNone
.Cells.UnMerge
End With

Set Frng = Range("B1:B" & LR).Find(Fstr, After:=Range("B1"), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
If Not Frng Is Nothing Then
FstRo = Frng.Row
LastRo = Frng.End(xlDown).Row - 1
    If LastRo = Rows.Count - 1 Then
    LastRo = Range("C" & Rows.Count).End(xlUp).Row
    End If
End If

Range("B" & FstRo & ":R" & LastRo).Copy Sheets("Copy").Range("B2")
Line1:
End Sub

Thanks for the compliment.

Try this revised code

Sub CopyData()

Dim X As Long, FstRo As Long, LastRo As Long
Dim Fstr As String
Dim Frng As Range

On Error GoTo Line1
Sheets("Packing").Activate

LR = Range("C" & Rows.Count).End(xlUp).Row

With Sheets("Copy")
Fstr = .Range("B2")
.Cells.Delete
.Cells.Interior.Pattern = xlNone
.Cells.Borders.LineStyle = xlNone
.Cells.UnMerge
End With

Set Frng = Range("B1:B" & LR).Find(Fstr, After:=Range("B1"), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
If Not Frng Is Nothing Then
FstRo = Frng.Row

If Frng.Offset(1, 0) = "" Then
LastRo = Frng.End(xlDown).Row - 1
    If LastRo = Rows.Count - 1 Then
    LastRo = Range("C" & Rows.Count).End(xlUp).Row
    End If
Else
LastRo = FstRo

End If


End If

Range("B" & FstRo & ":R" & LastRo).Copy Sheets("Copy").Range("B2")
Line1:
End Sub

This code is tested for all cases in example data.

Sub CopyData()

Dim X As Long, FstRo As Long, LastRo As Long
Dim Fstr As String
Dim Frng As Range

On Error GoTo Line1
Sheets("Packing").Activate

LR = Range("C" & Rows.Count).End(xlUp).Row

With Sheets("Copy")
Fstr = .Range("B2")
.Cells.Delete
.Cells.Interior.Pattern = xlNone
.Cells.Borders.LineStyle = xlNone
.Cells.UnMerge
End With

Set Frng = Range("B1:B" & LR).Find(Fstr, After:=Range("B1"), LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)
        
If Not Frng Is Nothing Then
FstRo = Frng.Row
k = Range("B" & FstRo + 1)

    If Frng.End(xlDown).Row = Rows.Count Then
    LastRo = Range("C" & Rows.Count).End(xlUp).Row
   
    Else

    T = 0
    Do While Range("B" & FstRo + T + 1) = ""
    T = T + 1
    Loop
    LastRo = FstRo + T
    
    End If

End If

Range("B" & FstRo & ":R" & LastRo).Copy Sheets("Copy").Range("B2")
Line1:
End Sub