Public Sub NAddr8FSS()
'Convert 1-Up Name and Address labels to Spread Sheet format.
'David McRitchie  http://www.mvps.org/dmcritchie/excel/excel.htm
'   1999-03-01  http://www.mvps.org/dmcritchie/excel/naddr2ss.txt
'   2001-04-10  http://www.mvps.org/dmcritchie/excel/code/naddr3ss.txt
'  description: http://www.mvps.org/dmcritchie/excel/snakecols.htm
'               modified for max of default 3 lines per input label
Dim nCol As Long, nRow As Long
Dim cRow As Long
Dim lastrow As Long
Dim wsSource As Worksheet
Dim wsNew As Worksheet
Dim linesPerSet As Variant  'Number of rows per label on input
linesPerSet = 8

nCol = 0
nRow = 1
lastrow = Cells.SpecialCells(xlLastCell).Row
Set wsSource = ActiveSheet
Set wsNew = Worksheets.Add
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'xl95 uses xlManual'Application.DisplayAlerts = False
'---- modified to include title from 1st word of 1st set of lines
For cRow = 1 To linesPerSet
  wsNew.Cells(1, cRow).Value = PartOne(wsSource.Cells(cRow, 1).Value)
Next cRow
nRow = 2
For cRow = 1 To lastrow
    If linesPerSet = nCol Then
       nRow = nRow + 1
       nCol = 1
    Else
       nCol = nCol + 1
    End If
    wsNew.Cells(nRow, nCol).Value = PartTwo(wsSource.Cells(cRow, 1))
Next cRow
Cells.EntireColumn.AutoFit
Application.Calculation = xlCalculationAutomatic 'xl95 uses xlAutomatic
Application.ScreenUpdating = True
End Sub
Private Function PartOne(pStr As String) As String
  If InStr(1, pStr, " ", 0) = 0 Then
    PartOne = pStr
  Else
    PartOne = Left(pStr, InStr(1, pStr, " ", 0) - 1)
  End If
End Function
Private Function PartTwo(pStr As String) As String
  If InStr(1, pStr, " ", 0) = 0 Then
    PartTwo = ""
  Else
    PartTwo = Trim(Mid(pStr, InStr(1, pStr, " ", 0) + 1))
  End If
End Function

Public Sub NAddr2SS4()
'Convert 1-Up Name and Address labels to Spread Sheet format.
'David McRitchie  http://www.mvps.org/dmcritchie/excel/excel.htm
'   1999-03-01  http://www.mvps.org/dmcritchie/excel/code/naddr8fss.txt
'   2001-01-25 as NAddr2SS4  to insure 4 columns
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 = 1
insureCol = 4  'insure this column is filled in...
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
        If nCol < insureCol Then
             wsNew.Cells(nRow, insureCol).Value = _
              wsNew.Cells(nRow, nCol).Value
            wsNew.Cells(nRow, nCol).Value = ""
        End If
     End If
     nRow = nRow + 1
     nCol = 0
   Else
      nCol = nCol + 1
      wsNew.Cells(nRow, nCol).Value = wsSource.Cells(cRow, 1).Value
   End If
Next cRow
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True     'place at end when debugged
Application.DisplayAlerts = True
End Sub