[VBA] If, move and concatenate

[devcon]

Αγαπητέ Θανάση,
Σε ευχαριστώ για την απάντησή σου.
Έλαβα την λύση και την παραθέτω για κάποιο άλλον που θα είχε το ίδιο πρόβλημα.

Option Compare Text
Option Explicit

Sub MoveValues()
Dim LR As Long
Dim Rw As Long
Dim MyStr As String
Dim MyOff As String

Application.ScreenUpdating = False  'Speeds up macro execution

'Determine last Cell In Column B
LR = Range("B" & Rows.Count).End(xlUp).Row

'Loop through Column B from the bottom up
    For Rw = LR To 2 Step -1
        If Cells(Rw, "A") = "" Then
            MyStr = Cells(Rw, "B") & " " & MyStr
            If InStr(MyStr, "offer") > 0 Then
                MyOff = MyStr
                MyStr = ""
            End If
        Else
            Cells(Rw, "C") = Application.WorksheetFunction.Trim(Cells(Rw, "B") & " " & MyStr)
            Cells(Rw, "D") = MyOff
            MyStr = ""
            MyOff = ""
        End If
    Next Rw

Range("C:D").WrapText = True
With Range("C1:D1")
    .Value = [{" Department","Offer"}]
    .Font.Bold = True
    .Borders(xlEdgeBottom).Weight = xlMedium
    .ColumnWidth = 43
End With

Application.ScreenUpdating = True
If MsgBox("Remove Old Data?", vbYesNo, "Confirm") = vbNo Then Exit Sub

Range("A3:A" & LR).SpecialCells(xlBlanks).EntireRow.Delete xlShiftUp
Range("B:B").Delete xlShiftToLeft

End Sub