Reformat Spreadsheet

[PamK]

I have a spreadsheet that needs to be reformatted. The attached sample shows how the data came in columns A & B. Columns E through L show how it needs to be reformatted. Any assistance would be greatly appreciated.

[mancubus]

below procedure will work for 5 consecutive rows of data of same structure for a single vendor no.
so you should manually copy/paste Address2 and Phone values to columns I and L and delete their rows .

i picked a cell value which is common to all records, "Short Name", to distinguish between records.


below is the key to access each record's field info. that means i assume all fields of all records are in the same row order.


BEN010

Benefits Brokers Exchange



Short Name:

Benefits B



Address:

1800 St. James Place, Ste. 650



Houston, TX




77056







Sub reorg()

Const srcText As String = "Short Name"
Dim fCell As Range
Dim firstAddress As String
Dim LastRow As Long

With Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
Set fCell = .Range("A2:A" & LastRow).Find(srcText)
If Not fCell Is Nothing Then
firstAddress = fCell.Address
Do
.Range("D" & fCell.Row - 1).Value = fCell.Offset(-1, 0).Value
.Range("E" & fCell.Row - 1).Value = fCell.Offset(-1, 1).Value
.Range("F" & fCell.Row - 1).Value = fCell.Offset(0, 1).Value
.Range("G" & fCell.Row - 1).Value = fCell.Offset(-1, 1).Value
.Range("H" & fCell.Row - 1).Value = fCell.Offset(1, 1).Value
.Range("J" & fCell.Row - 1).Value = fCell.Offset(2, 0).Value
.Range("K" & fCell.Row - 1).Value = fCell.Offset(3, 0).Value
Set fCell = .Range("A2:A" & LastRow).FindNext(fCell)
Loop While Not fCell Is Nothing And fCell.Address <> firstAddress
End If
End With

End Sub

[PamK]

Thank you so much for the help! Greatly appreciated.

[mancubus]

you are welcome. im glad it helped.