Rearrange Data

[smithbj]

I have an address spreadsheet that has approximately 7,000 addresses
that appears as follows:

__(A)___(B)_____(C)_____(D)______________(E)_____(F)___(G)
NAME_TITLE__FACILITY_STREET_______CITY/STATE__ZIP___PHONE #
John__Clerk____East___123 Main_______Atlanta, GA__05821__217-555-1111
Mary__Typist___West__2321 South St___Miami, FL___01251__654-555-4544
Fred___Director_South_847 12 Street____Kearny, NJ_98511___362-555-2313

I want to rearrange it to appear as follows:
__(A)_____________(B)____(C)_________(D)__________(E)

John____________________Clerk____________________217-555-1111
123 Main________________ East
Atlanta, GA_______05821

Mary____________________Typist____________________654-555-4544
2321 South St____________West
Miami, FL__________01251

Fred____________________Director__________________362-555-2313
847 12 Street____________South
Kearny, NJ_________98511


Does anyone have any code that would programmatically rearrange the
spreadsheet as above. Any help would be appreciated.

 

[a7n9]

Hi,

First make a copy of your worksheet. Second select the data and run
this macro.


Code:
--------------------
Sub ReArrangeIt()
On Error Resume Next
Dim DataArr
Application.ScreenUpdating = False
Dim iRows As Integer, iCols As Integer
iRows = Selection.Rows.Count
iCols = Selection.Columns.Count
DataArr = ActiveSheet.Range(Cells(2, 1), Cells(iRows, iCols))
ActiveSheet.Cells.ClearContents
Dim i As Integer, iCntr As Integer
iCntr = 1
For i = 1 To iRows - 1
Range("A" & iCntr) = DataArr(i, 1) 'Name
Range("C" & iCntr) = DataArr(i, 2) 'Title
Range("E" & iCntr) = DataArr(i, 7) 'Phone
iCntr = iCntr + 1
Range("A" & iCntr) = DataArr(i, 4) 'St
Range("C" & iCntr) = DataArr(i, 3) 'Facility
iCntr = iCntr + 1
Range("A" & iCntr) = DataArr(i, 5) 'City/State
Range("B" & iCntr) = DataArr(i, 6) 'Zip
iCntr = iCntr + 2
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub

 

[NickHK]

You could record a macro whilst you cut/insert the columns in the correct
order.
Advisable to work on a copy until you get the code correct.

NickHK

 

[Graham Whitehead]

Hi there,

Look at the attached workbook example - i think this is what you are looking
for.
Here is the code:

Sub sort_names()

Dim lngLastRow As Long
Dim x As Integer
Dim lngOffsetCounter As Long
Dim arrName() As String
Dim arrTitle() As String
Dim arrFacility() As String
Dim arrStreet() As String
Dim arrCity() As String
Dim arrZip() As String
Dim arrPhone() As String

'find number of entries
With ActiveSheet
lngLastRow = .Range("A65536").End(xlUp).Row
End With

lngOffsetCounter = 4

ReDim arrName(lngLastRow) As String
ReDim arrTitle(lngLastRow) As String
ReDim arrFacility(lngLastRow) As String
ReDim arrStreet(lngLastRow) As String
ReDim arrCity(lngLastRow) As String
ReDim arrZip(lngLastRow) As String
ReDim arrPhone(lngLastRow) As String

For x = 0 To lngLastRow - 1
arrName(x) = Range("A" & x + 2).Value
arrTitle(x) = Range("B" & x + 2).Value
arrFacility(x) = Range("C" & x + 2).Value
arrStreet(x) = Range("D" & x + 2).Value
arrCity(x) = Range("E" & x + 2).Value
arrZip(x) = Range("F" & x + 2).Value
arrPhone(x) = Range("G" & x + 2).Value
Next x

Sheets("Sheet2").Select
For x = 0 To lngLastRow - 1
Range("A1").Offset((x * lngOffsetCounter) + 1, 0).Value = arrName(x)
Range("C1").Offset((x * lngOffsetCounter) + 1, 0).Value =
arrTitle(x)
Range("E1").Offset((x * lngOffsetCounter) + 1, 0).Value =
arrPhone(x)
Range("A2").Offset((x * lngOffsetCounter) + 1, 0).Value =
arrStreet(x)
Range("C2").Offset((x * lngOffsetCounter) + 1, 0).Value =
arrFacility(x)
Range("A3").Offset((x * lngOffsetCounter) + 1, 0).Value = arrCity(x)
Range("C3").Offset((x * lngOffsetCounter) + 1, 0).Value = arrZip(x)
Next x

End Sub