Reorganize Side by Side Address Sheets

[njeswani]

I have an address sheet where they are side by side and in note pad. I want to import them to excel like a standard mailing list, with columns for First Name, Last Name, Address, City, State, Zip, but I don't know how to rearrange the formatting.

This is more clearly what the current sheet looks like (but with spacing between the side by side addresses). I was able to import to excel using fixed width delineation, which then split up the addresses into 3 distinct columns.

Mary Member Mary Member Mary Member
555 South Ln.555 South Ln.555 South Ln.
Lan, FL 9238 Land, FL 9238 Lan, FL 9238
415555-5555 415-555-5555 415555-5555

Mary Member Mary Member Mary Member
555 South Ln.555 South Ln.555 South Ln.
Lan, FL 9238 Land, FL 9238 Lan, FL 9238
415555-5555 415-555-5555 415555-5555

 

[Ruddles]

How many addresses are there in total?

Are there always four rows per address, a blank row, then another four rows - exactly like your sample?

Are they in columns A-C?

Do you want to do this just once or will you want to repeat this operation again in the future?

 

[njeswani]

There's 8000-10000 addresses, most of the entries are 4 rows (Name, Address, City/State/Zip, Phone). Some of them are longer if they have two rows for address. There are also 1-3 rows separating every set of three addresses, and in the spaces in column A, there is typically a two way arrow symbol . For now, the three side by side addresses are in columns A-C.

This process only needs to be done once.

 

[Ruddles]

You could give this a try. Paste this code into a new general code module in a copy of your worksheet and run it.

[FONT=Fixedsys]Option Explicit[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]Public Sub ReformatAddressLabels()[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]  Dim iLastRow As Long
  Dim iDestRow As Long
  Dim iRow As Long
  Dim oRow As Long
  Dim oColumn As Long
  Dim oMaxColumn As Long
  
  With ThisWorkbook.Sheets(1)
  
    iDestRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
    iLastRow = .Cells(.Rows.Count, 2).End(xlUp).Row
    .Range("B1:B" & CStr(iLastRow)).Copy Destination:=.Range("A" & CStr(iDestRow))
    iDestRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
    iLastRow = .Cells(.Rows.Count, 3).End(xlUp).Row
    .Range("C1:C" & CStr(iLastRow)).Copy Destination:=.Range("A" & CStr(iDestRow))
    .Columns("B:C").EntireColumn.Delete
    iLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    
    oRow = 1
    oColumn = 2
    .Cells(1, 1).Copy Destination:=.Cells(1, 2)
    For iRow = 2 To iLastRow
      If IsLine(.Cells(iRow, 1)) And Not IsLine(.Cells(iRow - 1, 1)) Then
        oColumn = 2
        oRow = oRow + 1
      Else
        oColumn = oColumn + 1
        If oColumn > oMaxColumn Then oMaxColumn = oColumn
      End If
      If IsLine(.Cells(iRow, 1)) Then
        .Cells(iRow, 1).Copy Destination:=.Cells(oRow, oColumn)
      End If
    Next iRow
    
    For oColumn = 2 To oMaxColumn
      .Columns(oColumn).EntireColumn.AutoFit
    Next oColumn
    
  End With[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]End Sub[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]Private Function IsLine(ByVal arg As String) As Boolean[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]  IsLine = False
  
  Select Case Left(arg, 1)
    Case "0" To "9", "a" To "z", "A" To "Z"
      IsLine = True
  End Select[/FONT]
[FONT=Fixedsys][/FONT] 
[FONT=Fixedsys]End Function[/FONT]

Check the output carefully to ensure that I've understood your requirements fully and that the code is producing the correct results.