Option Explicit
Dim newWorkbook As Workbook
Sub MainRoutine()
Call ImportFromAddressBook
Call RearrangeData
Call parseNewWorksheet
Application.Dialogs(xlDialogSaveAs).Show , 1
End Sub
Private Sub parseNewWorksheet(Optional argument As Boolean)
Dim rangeWidth As Long, oneCell As Range
With newWorkbook.Sheets(1)
With Range(.Cells(1, .Columns.Count).End(xlToLeft), .Cells(.Rows.Count, 1).End(xlUp))
rangeWidth = .Columns.Count
Rem remove semi-colons
.Offset(0, rangeWidth).FormulaR1C1 = "=TRIM(SUBSTITUTE(RC[-" & .Columns.Count & "],"";"","" ""))"
.Offset(0, rangeWidth).FormulaR1C1 = "=ParsingAddresses.xls!CleanDelimiters(RC[-" & .Columns.Count & "])"
With .Resize(, rangeWidth - 1)
.Value = .Offset(0, rangeWidth).Value
.Offset(0, rangeWidth).Delete shift:=xlToLeft
End With
Rem parse address column
With .Offset(0, rangeWidth + 1).Columns(1)
.FormulaR1C1 = "=MID(RC[-2],FIND(LEFT(RC[-1],1),RC[-2]),1000)"
.Value = .Value
.Offset(0, -2).Resize(, 2).EntireColumn.Delete
End With
On Error Resume Next
.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
End With
Rem format headers
With Range(.Cells(1, .Columns.Count).End(xlToLeft), .Cells(.Rows.Count, 1).End(xlUp))
With .Rows(1)
.HorizontalAlignment = xlCenter
With .Font
.Bold = True
.Underline = xlUnderlineStyleSingle
End With
End With
.Columns.AutoFit
Rem format phone numbers
For rangeWidth = 1 To .Columns.Count
If .Cells(1, rangeWidth) Like "*Phone*" Then
With Range(.Cells(2, rangeWidth), Cells(.Rows.Count, rangeWidth))
For Each oneCell In .Cells
If oneCell <> vbNullString Then
oneCell.Value = NumbersOnly(oneCell.Value)
End If
Next oneCell
.NumberFormat = "[<=9999999]###-####;(###) ###-####"
End With
End If
Next rangeWidth
End With
End With
End Sub
Private Sub RearrangeData(Optional argument As Boolean)
Dim fieldIndicators 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
fieldIndicators = 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")
On Error GoTo HaltRoutine
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))
Rem rejoin colon delimited data
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
Rem rearrange data
ReDim outRRay(Application.CountIf(.Cells, "BEGIN"), 1 To UBound(Headers) + 1)
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(fieldIndicators)
If testVal Like fieldIndicators(putCol) Then
outRRay(putRow, putCol + 1) = putVal
Exit For
End If
Next putCol
End If
Next lookRow
Rem write to sheet
With .Parent.Range("C1")
.Resize(1, UBound(Headers) + 1).Value = Headers
.Offset(1, 0).Resize(UBound(outRRay, 1), UBound(outRRay, 2)).Value = outRRay
End With
Rem remove old data
.Resize(, 2).EntireColumn.Delete
End With
End With
On Error GoTo 0
Exit Sub
HaltRoutine:
On Error GoTo 0
MsgBox "There is a problem with the imported data."
End
End Sub
Private Sub ImportFromAddressBook(Optional argument As Boolean)
Dim pathStr As String
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
Function NumbersOnly(ByVal inputString As String) As Double
Dim i As Long, oneChar As String, outStr As String
inputString = "a" & inputString
For i = 1 To Len(inputString)
oneChar = Mid(inputString, i, 1)
If oneChar Like "[0-9]" Then
outStr = outStr & oneChar
End If
Next i
NumbersOnly = Val(outStr & ".0")
End Function
Function CleanDelimiters(ByVal inputString As String, Optional Delimiter As String) As String
If Delimiter = vbNullString Then Delimiter = ";"
inputString = Trim(inputString)
If Left(inputString, 1) = Delimiter Then
CleanDelimiters = CleanDelimiters(Mid(inputString, 2), Delimiter)
Else
CleanDelimiters = Application.Trim(Application.Substitute((Application.Substitute(inputString, Delimiter, ", ", 1)), ";", " "))
End If
End Function
If not, and you can point me to a good MacForum, I'll settle.
