Turn 1 huge column into 7 with rows separated by certain values

[Gingertrees]

Organizing addresses again, I have a long list with up to 7 rows per entry. I have labeled this thusly:

[COLUMN A..............][.B..]
SMITH'S PARTS............1
300 MAIN ST, ABE NC......2
PHONE: 300-222-2222......3
FAX......................4
WEB: WWW.____.NET........5
CONTACT: JON SMITH.......6
GET DIRECTIONS...........7
OAKVILLE STORE...........1
12 ARBOR RD, BLISS ID....2
PHONE: 800-345-2222......3
FAX......................4
CONTACT: JERRY JACK......6
GET DIRECTIONS...........7

Since not all businesses have Fax info, or a website, sometime there is no line 4 or 5, so the numbers go like this:
...1
...2
...3
...6
...7
...1
...2
...3
...4
...6
...7
(etc)
This is in one big column of numbers (column B). There's always a 1,2,3, 6,and 7. The middle ones get tricky.

I want to change from that column to rows with 7 columns.
IS there some way (vlookup? VBA?) that Excel can know "7=last column in a row, start new row". Also, "4 does not exist, skip to next cell"

Name.......Addr........Phone...Fax...Web...Contact...Directions

Crosspost at the bottom of a long and ignored thread:
http://www.mrexcel.com/forum/showthread.php?t=613879&page=2

 

[BenMiller]

Select B1 and try this, making sure you have six empty columns to the right.
(C-H)

Sub Macro1()
'
' Macro1 Macro
'
'

'
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Cut
    ActiveCell.Offset(-1, 1).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(2, -1).Range("A1").Select
    Selection.Cut
    ActiveCell.Offset(-2, 2).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(3, -2).Range("A1").Select
    Selection.Cut
    ActiveCell.Offset(-3, 3).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(4, -3).Range("A1").Select
    Selection.Cut
    ActiveCell.Offset(-4, 4).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(5, -4).Range("A1").Select
    Selection.Cut
    ActiveCell.Offset(-5, 5).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(6, -5).Range("A1").Select
    Selection.Cut
    ActiveCell.Offset(-6, 6).Range("A1").Select
    ActiveSheet.Paste
    ActiveCell.Offset(1, -6).Range("A1:A6").Select
    Selection.Delete Shift:=xlUp
    ActiveCell.Select
End Sub

 

[circledchicken]

Hi,

For a formula alternative maybe try something like this:

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K
1	SMITH'S PARTS	1			Name	Addr	Phone	Fax	Web	Contact	Directions
2	300 MAIN ST, ABE NC	2		7	SMITH'S PARTS	300 MAIN ST, ABE NC	PHONE: 300-222-2222	FAX: 2353	WEB: WWW.____.NET	CONTACT: JON SMITH	GET DIRECTIONS
3	PHONE: 300-222-2222	3		12	OAKVILLE STORE	12 ARBOR RD, BLISS ID	PHONE: 800-345-2222			CONTACT: JERRY JACK	GET DIRECTIONS
4	FAX: 2353	4
5	WEB: WWW.____.NET	5
6	CONTACT: JON SMITH	6
7	GET DIRECTIONS	7
8	OAKVILLE STORE	1
9	12 ARBOR RD, BLISS ID	2
10	PHONE: 800-345-2222	3
11	CONTACT: JERRY JACK	6
12	GET DIRECTIONS	7
Sheet1

Excel 2010

Cell Formulas
Range	Formula
E2	=IFERROR(INDEX(INDEX($A:$A,$D1+1):INDEX($A:$A,$D2),MATCH(COLUMNS($E$1:E$1),INDEX($B:$B,$D1+1):INDEX($B:$B,$D2),0)),"")

#VALUE!

Entered with Ctrl+Shift+Enter. If entered correctly, Excel will surround with curly braces {}.

• Drag down the formula in D2 (you need to use CTRL-SHIFT-ENTER rather than just ENTER for this one as it is an array formula). Also, change both 12's in the D2 formula to the last row in your column.
• Drag across the formula in E2 to K2 and then down (this just needs the normal ENTER)

 

[circledchicken]

For a slightly simplified version of the E2 formula, perhaps:

=IFERROR(INDEX($A:$A,MATCH(COLUMNS($E$1:E$1),INDEX($B:$B,$D1+1):INDEX($B:$B,$D2),0)+$D1),"")

 

[Gingertrees]

circledchicken: you are the BOMB! I spent far too long trying to get an insert-row macro to work. Thank you thank you thank you!!

 

[Rick Rothstein]

I spent far too long trying to get an insert-row macro to work.

If you still wanted to do this with a macro and avoid the formulas, I am pretty sure this macro works the way you want...

Sub DistributeDataAcrossColumns()
  Dim X As Long, LastRow As Long, NameRow As Long, Sevens As Range
  Const StartRow As Long = 1
  LastRow = Cells(Rows.Count, "B").End(xlUp).Row
  Columns("B").Replace 7, "=7", xlWhole
  Set Sevens = Columns("B").SpecialCells(xlFormulas)
  NameRow = StartRow
  For X = StartRow To LastRow
    Cells(NameRow, Cells(X, "B").Value + 4).Value = Cells(X, "A")
    If Cells(X, "B").Value = 7 Then NameRow = NameRow + 1
  Next
End Sub

 

[circledchicken]

Your welcome, I like this macro method too.