Sub ImportData()
Dim rng As Range
Dim strData() As String
Dim iData As Integer, iTMP As Integer, strTMP As String, varTMP As Variant
Dim iItem As Integer
iData = -1
For Each rng In Intersect(ActiveSheet.UsedRange, Range("B:B")).Cells
strTMP = rng.Value
If strTMP <> "" Then
varTMP = Split(rng.Value, vbLf)
For iTMP = 0 To UBound(varTMP)
iData = iData + 1
ReDim Preserve strData(iData)
strData(iData) = varTMP(iTMP)
Debug.Print varTMP(iTMP)
Next
End If
Next
If iData > -1 Then
For iItem = 0 To UBound(strData)
Cells(iItem + 1, 2) = strData(iItem)
Next
End If
End Sub