Option Explicit
Option Base 1
Sub TransferData()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim iLastRow As Long
Dim SplitArray() As String
Dim ResultsArray() As String
Dim iRowsToTransfer As Long
Dim rSourceData As Range
Dim rResultsData As Range
Dim rCell As Range
Dim bPreviousWasEmpty As Boolean
Set wsSource = ThisWorkbook.Worksheets("Sheet1")
On Error Resume Next
Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
On Error GoTo 0
If wsTarget Is Nothing _
Then Set wsTarget = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
iLastRow = wsSource.Range("A1").Offset(1000000).End(xlUp).Row
Set rSourceData = wsSource.Cells(1, 1).Resize(iLastRow)
For Each rCell In rSourceData
If UCase(rCell.Value) = UCase("SKIP") Or rCell.Value = "" _
Then
bPreviousWasEmpty = True
Else
If bPreviousWasEmpty _
Then
iRowsToTransfer = iRowsToTransfer + 1
ReDim Preserve ResultsArray(3, iRowsToTransfer)
ResultsArray(1, iRowsToTransfer) = rCell.Value
Else
SplitArray = Split(rCell.Value, " at ", -1, vbTextCompare)
ResultsArray(2, iRowsToTransfer) = SplitArray(0)
If UBound(SplitArray) <> 0 _
Then ResultsArray(3, iRowsToTransfer) = SplitArray(1)
End If
bPreviousWasEmpty = False
End If
Next rCell
wsTarget.Cells.Clear
Set rResultsData = wsTarget.Cells(1, 1).Resize(iRowsToTransfer, 3)
rResultsData.Value = Application.Transpose(ResultsArray())
MsgBox "Names processed = " & iRowsToTransfer & ".", vbInformation, "Processing names."
End Sub