Option Explicit
Dim newWorkbook As Workbook
Sub MainRoutine()
Call ImportFromAddressBook
Call RearrangeData
End Sub
Sub RearrangeData()
'Set newWorkbook = Application.Workbooks("aTest.vcf")
Dim fileList As Variant, Headers As Variant
Dim outRRay As Variant
Dim lookRow As Long, putRow As Long, putCol As Long
Dim testVal As String, putVal As String
fileList = Array("N", "EMAIL*WORK*", "EMAIL*HOME*", "TEL*WORK*", "TEL*CELL*", "TEL*HOME*", "*URL*", "CATEGORIES*", "*.ADR*")
Headers = Array("Name", "WorkE-mail", "HomeE-Mail", "WorkPhone", "CellPhone", "HomePhone", "URL", "Category", "Address")
With newWorkbook.Sheets(1).Range("A:A")
With Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=":", FieldInfo:=Array(Array(1, 1), Array(2, 1))
End With
With Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
With .Offset(0, 3)
.FormulaR1C1 = "=RC[-2]&IF(LEN(RC[-1])=0,"""","":""&RC[-1])"
.Value = .Value
End With
.Offset(0, 1).Resize(, 2).Delete shift:=xlToLeft
ReDim outRRay(1 To UBound(Headers) + 1, 1 To .Rows.Count)
For lookRow = 1 To .Rows.Count
testVal = .Cells(lookRow, 1).Value
putVal = .Cells(lookRow, 2).Value
If testVal = "BEGIN" Then
putRow = putRow + 1
Else
For putCol = 0 To UBound(fileList)
If testVal Like fileList(putCol) Then
outRRay(putCol + 1, putRow) = putVal
Exit For
End If
Next putCol
End If
Next lookRow
ReDim Preserve outRRay(1 To UBound(outRRay, 1), 1 To putRow)
With .Parent.Range("C1")
.Resize(1, UBound(Headers) + 1).Value = Headers
.Offset(1, 0).Resize(UBound(outRRay, 2), UBound(outRRay, 1)).Value = Application.Transpose(outRRay)
End With
.Resize(, 2).EntireColumn.Delete
End With
End With
End Sub
Sub ImportFromAddressBook()
Dim pathStr As String
Dim resultRRay As Variant
Dim rNum As Long, outPoint As Long
pathStr = Application.GetOpenFilename
If Not (pathStr = "False") Then
On Error GoTo HaltRoutine
Set newWorkbook = Workbooks.Open(pathStr)
End If
On Error GoTo 0
Exit Sub
HaltRoutine:
On Error GoTo 0
MsgBox "File Error"
End
End Sub
If not, and you can point me to a good MacForum, I'll settle.
