Creating an Excel sheet with Addresses using a Macro

[Guest]

I have a list of addresses that are sepperated by a blank row. The address
number around 4000. All information is stored in Column A down each of the
rows. Instead, I would like it go across so that it is easy to merge into a
document for mailing. The addresses are similar to those below:

Company Name 1
123 Company Road
Any Town, AL 12345 - 6789
(555) 555-5555

Company Name 2
234 Company Road
Another Town, AK 23456-7890
(555) 555-0000

Company Name 3
Different Town, NY 34567-6543
(555) 555-1111

As you can see, some have three and some have four rows for the address (not
all of them have street addresses in them). What I want is something like
this:

Company Name 1 1234 Company Road Any Town, AL 12345 - 6789 (555)
555-5555
Company Name 2 234 Company Road Another Town, AK 23456-7890 (555)
555-0000
Company Name 3 Different Town, NY
34567-6543 (555) 555-1111

(Please note, I want the phone number in one column as it normally would
appear.) Just so you know, all of the Company Names are bold and of a blue
color (instead of black); not all of the zip codes are nine-digit, some are
five digit; all of the street addresses start with a number or "PO Box"; the
phone numbers are all formatted as (###) ###-#### and are bold; and there is
a blank (empty) cell at the end of each address. I have very little Macro
Programming, but I was thinking of something along the rough idea of:

Go to cell A2 and do the following for each
If the color of the selected cell is blue, then leave it where it is.
Increase the row of column A by 1 (in this case, A3)
If the selected cell begins with a number or "PO Box", then cut and paste it
to Column B one row above it's current spot, else cut and paste it to Column
C one row above it's current spot. Delete the empty cell left from the cut.
If the selected cell begins with a "(", then cut and paste it to Column D
one row above it's current spot. Delete the empty cell left from the cut.
If the selected cell is empty, then delete the empty cell and shift the rows
up.

Obviously this isn't programming language, but I thought I would get my
ideas out on paper first before attempting to get some coding help. Thanks
in advance for anyone's thoughts, comments, suggestions, and help on this!

Aaron

 

[Dave Peterson]

Try running this against a copy of your worksheet--it'll destroy the original.

Option Explicit
Sub testme()

Dim wks As Worksheet
Dim iRow As Long
Dim myRng As Range
Dim myStr As String
Dim myDigits As String
Dim myArea As Range
Dim TopRow As Long

Set wks = Worksheets("Sheet1")
With wks
Set myRng = Nothing
On Error Resume Next
Set myRng = .Range("a:a").Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0

If myRng Is Nothing Then
'keep going
Else
MsgBox "Please convert formulas to values!"
Exit Sub
End If

Set myRng = Nothing
On Error Resume Next
Set myRng = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp)) _
.Cells.SpecialCells(xlCellTypeConstants)
On Error GoTo 0

If myRng Is Nothing Then
MsgBox "No constants found!"
Exit Sub
End If
End With

For Each myArea In myRng.Areas
With myArea
For iRow = .Row To .Cells(.Cells.Count).Row
myStr = Trim(.Parent.Cells(iRow, "A").Value)
If iRow = .Row Then
TopRow = iRow
.Parent.Cells(TopRow, "c").Value = myStr
Else
If LCase(Left(myStr, 2)) = "po" _
Or LCase(Left(myStr, 5)) = "pobox" _
Or LCase(Left(myStr, 6)) = "po box" _
Or IsNumeric(Left(myStr, 1)) Then
.Parent.Cells(TopRow, "d").Value = myStr
Else
With Application
myDigits = myStr
myDigits = .Substitute(myDigits, "(", "")
myDigits = .Substitute(myDigits, ")", "")
myDigits = .Substitute(myDigits, " ", "")
myDigits = .Substitute(myDigits, "-", "")
myDigits = .Substitute(myDigits, ".", "")
End With
If IsNumeric(myDigits) Then
.Parent.Cells(TopRow, "F").Value = myStr
Else
If IsNumeric(Right(myStr, 4)) _
And IsNumeric(Left(myStr, 1)) = False Then
.Parent.Cells(TopRow, "E").Value = myStr
Else
.Parent.Cells(iRow, "B").Value = "***ERROR***"
End If
End If
End If
End If
Next iRow
End With
Next myArea

With wks
If Application.CountIf(.Range("B:B"), "*error*") > 0 Then
MsgBox "Errors found!"
Exit Sub
Else
On Error Resume Next
.Range("C:C").Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
On Error GoTo 0
.Range("a:b").Delete
End If
.UsedRange.EntireColumn.AutoFit
End With

End Sub

I didn't use the boldness of the cell to determine the company name--I just used
the first cell in that grouping.

 

[Guest]

Thanks, Dave! This got it very close. I was able to finish up using what
you gave me. Again, thanks!

Aaron