Sub Reformat_List()
Dim xCell As Range
Dim xInputSheet As Worksheet
Dim xOutputSheet As Worksheet
Dim xLastRow As Long
Dim i As Long
Dim xName As String
Dim xCompany As String
Dim xDivision As String
Dim xEmail As String
Dim xPhone As String
Dim xTitle As String
Set xInputSheet = ActiveSheet
Set xOutputSheet = Sheets.Add
xOutputSheet.Range("A1:F1").Value = Array("Name", "Company", "Division", "Email Address", "Phone", "Title")
i = 2
xInputSheet.Activate
xLastRow = ActiveSheet.Range("A1").SpecialCells(xlLastCell).Row
For Each xCell In xInputSheet.Range("A1:A" & xLastRow)
If xCell.Offset(0, 1) <> "" Then
xName = xCell
xTitle = xCell.Offset(0, 1)
Else
If xCell = "" Then
' Ignore blank rows
ElseIf InStr(1, xCell, "@") > 0 Then
xEmail = xCell
ElseIf Left(xCell, 1) = "(" Then
xPhone = xCell
ElseIf IsDate(xCell) Then
' Ignore Date
ElseIf xCell.Offset(-1, 1) <> "" Then
xCompany = xCell
Else
xDivision = xCell
End If
If xCell.Offset(1, 1) <> "" Or xCell.Row = xLastRow Then
xOutputSheet.Cells(i, 1) = xName
xOutputSheet.Cells(i, 2) = xCompany
xOutputSheet.Cells(i, 3) = xDivision
xOutputSheet.Cells(i, 4) = xEmail
xOutputSheet.Cells(i, 5) = xPhone
xOutputSheet.Cells(i, 6) = xTitle
xName = ""
xCompany = ""
xDivision = ""
xEmail = ""
xPhone = ""
xTitle = ""
i = i + 1
End If
End If
Next
End Sub
ElseIf xCompany = "" Then
(1) Will every entry have at least a Name, Company, Email Address, Date and Title?
(2) Are there any other entries that might appear (including blank rows)?
(3) Will every entry have the same sequence in column A, i.e. Name, Company, Division (optional), Email Address, Phone No (optional) and Date?
(4) What version of Excel do you (or the user(s)) have?
Thanks,
Brian.