Boa tarde,

Veja se este código atende:

Sub CopiarNegrito()
    Dim i As Integer
    Dim Texto As String
    
    For i = 1 To [A1].CurrentRegion.Rows.Count
        If Cells(i, 1).Font.Bold Then
            Texto = Cells(i, 1).Value
        Else
            Cells(i, 5).Font.Bold = True
            Cells(i, 5).Value = Texto
        End If
    Next
End Sub

Abraço

Deu certinho!
Valeu!