Sub blah2()
Dim rngHighLight As Range
Set Destn = Range("O2")
Set myrng = Range("A1").CurrentRegion
Set myrng = Intersect(myrng, myrng.Offset(1))
SceVals = myrng.Value
ReDim Results(1 To myrng.Cells.Count, 1 To 4)
rw = 0
For r = 1 To UBound(SceVals)
For c = 3 To UBound(SceVals, 2) - 1
If Len(SceVals(r, c + 1)) > 0 Then
rw = rw + 1
Results(rw, 1) = SceVals(r, 1)
Results(rw, 2) = SceVals(r, 2)
Results(rw, 3) = SceVals(r, c)
Results(rw, 4) = SceVals(r, c + 1)
If c = 3 Then If rngHighLight Is Nothing Then Set rngHighLight = Destn.Offset(rw - 1, 2) Else Set rngHighLight = Union(rngHighLight, Destn.Offset(rw - 1, 2))
Else
Exit For
End If
Next c
Next r
With Destn.Resize(rw, 4)
.Value = Results
.ClearFormats
.Offset(, 2).Resize(, 2).Font.Color = vbRed '-16776961
End With
rngHighLight.Font.ColorIndex = xlAutomatic
End Sub