Public Sub NAddrDB()
'Convert 1-Up Name and Address labels to Spread Sheet format.
'David McRitchie  http://www.mvps.org/dmcritchie/excel/code/naddrdb.txt
'   2002-05-05 NAddrDB macro work with names as arg in A and value in B
'    will accept Arguments in any order within blank row delimited ranges
Dim nCol As Long, nRow As Long, cRow As Long, lastrow As Long
Dim insureCol As Long
Dim wsSource As Worksheet, wsNew As Worksheet
Dim lastcell As Range
nCol = 0
nRow = 2
Dim Desc(50) As Variant
Dim Dsub  As Long
Dsub = 0
Dim I As Long
Set lastcell = Cells.SpecialCells(xlLastCell)
lastrow = lastcell.Row + 1  'adjustment to help with insureCol
Set wsSource = ActiveSheet
Set wsNew = Worksheets.Add
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For cRow = 1 To lastrow
   If Trim(wsSource.Cells(cRow, 1).Value) = "" Then
     If nCol <> 0 Then nRow = nRow + 1
     nCol = 0
   Else
     nCol = 1  'not zero
     For I = 1 To Dsub
        If wsSource.Cells(cRow, 1) = Desc(I) Then
           wsNew.Cells(nRow, I).Value = wsSource.Cells(cRow, 2).Value
           GoTo nextcrow
        End If
     Next I
     Dsub = Dsub + 1
     wsNew.Cells(1, Dsub) = wsSource.Cells(cRow, 1).Value
     Desc(Dsub) = wsSource.Cells(cRow, 1).Value
     wsNew.Cells(nRow, Dsub).Value = wsSource.Cells(cRow, 2).Value
     wsNew.Cells(nRow, Dsub).NumberFormat = wsSource.Cells(cRow, 2).NumberFormat
     GoTo nextcrow
   End If
nextcrow:
Next cRow
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True     'place at end when debugged
Application.DisplayAlerts = True
End Sub