Move data from blocks to vertical rows

[Hagbo]

Hi all,

I am looking to move data from this format:
<!--[if !mso]><style>v\:* {behavior:url(#default#VML);}o\:* {behavior:url(#default#VML);}x\:* {behavior:url(#default#VML);}.shape {behavior:url(#default#VML);}</style><![endif]-->

Trading Name:	BRAD GARLICK FORD
Division:	[ Automobile Dealers Metro ]
Address:	2-16 BLAXLAND ROAD
	RYDE
	NSW, 2112
Phone:	02 9807-2933
Fax:	02 9808-2501

<tbody>
</tbody>

Trading Name:	BROOKVALE MAZDA
Division:	[ Automobile Dealers Metro ]
Address:	786 PITTWATER RD
	BROOKVALE
	NSW, 2100
Phone:	029939-7677
Fax:	029939-7944

<tbody>
</tbody>

To this format:

Trading Name	Division	Address	Address 1	State	Postcode	Phone	Fax
BRAD GARLICK FORD	Automobile Dealers Metro	2-16 BLAXLAND ROAD	RYDE	NSW	2112	02 9807-2933	029939-7944
BROOKVALE MAZDA	Automobile Dealers Metro	blah	blah	blah	blah	blah	blah

<tbody>
</tbody>

I'm basically wanting to convert blocks of data to logical rows and columns as well as split out the postcode and state from the same cell into another column.

Any help would be appreciated!

Regards,

Paul

 

[Hagbo]

Each entry should only be one row, not the 2 showing above E.g. "Brad Garlick Ford" should be one row, not have "Ford" on a separate row.

 

[Peter_SSs]

Welcome to the MrExcel board!

Try this in a copy of your workbook.

Sub RearrangeDetails()
   Dim a As Variant, b As Variant, adrbits As Variant
   Dim i As Long, j As Long, k As Long, UB As Long
   Dim adr As String
   
   a = Range("A1", Range("B" & Rows.Count).End(xlUp)).Value
   ReDim b(1 To UBound(a), 1 To 8)
   For i = 1 To UBound(a)
    If Not IsEmpty(a(i, 2)) Then
      Select Case LCase(a(i, 1))
        Case "trading name:"
          k = k + 1
          b(k, 1) = a(i, 2)
        Case "division:"
          b(k, 2) = Trim(Replace(Replace(a(i, 2), "[", ""), "]", ""))
        Case "address:"
          adr = a(i, 2)
        Case ""
          adr = adr & ":" & a(i, 2)
        Case "phone:"
          adrbits = Split(adr, ":")
          UB = UBound(adrbits)
          adr = adrbits(0)
          For j = 1 To UB - 2
            adr = adr & vbLf & adrbits(j)
          Next j
          b(k, 3) = adr
          b(k, 4) = adrbits(UB - 1)
          b(k, 5) = Split(adrbits(UB), ",")(0)
          b(k, 6) = Trim(Split(adrbits(UB), ",")(1))
          b(k, 7) = a(i, 2)
        Case "fax:"
          b(k, 8) = a(i, 2)
      End Select
    End If
   Next i
   With Range("F1:M1")
    .Value = Array("Trading Name", " Division", "Address", "Address 1", "State", "Postcode", "Phone", "Fax")
    .Offset(1).Resize(k).Value = b
    .EntireColumn.AutoFit
   End With
End Sub

Sample data & results. I've assumed some address blocks contain more than 3 rows - see rows 22-25.

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L	M
1						Trading Name	Division	Address	Address 1	State	Postcode	Phone	Fax
2	Trading Name:	BRAD GARLICK FORD				BRAD GARLICK FORD	Automobile Dealers Metro	2-16 BLAXLAND ROAD	RYDE	NSW	2112	02 9807-2933	02 9808-2501
3	Division:	[ Automobile Dealers Metro ]				BROOKVALE MAZDA	Automobile Dealers Metro	786 PITTWATER RD	BROOKVALE	NSW	2100	029939-7677	029939-7944
4	Address:	2-16 BLAXLAND ROAD				SOMEBODY	Automobile Dealers Metro	Shop 23Big Industrial Estate	SOME TOWN	NSW	2222	02 123-456	026639-7944
5		RYDE
6		NSW, 2112
7	Phone:	02 9807-2933
8	Fax:	02 9808-2501
9
10
11	Trading Name:	BROOKVALE MAZDA
12	Division:	[ Automobile Dealers Metro ]
13	Address:	786 PITTWATER RD
14		BROOKVALE
15		NSW, 2100
16	Phone:	029939-7677
17	Fax:	029939-7944
18
19
20	Trading Name:	SOMEBODY
21	Division:	[ Automobile Dealers Metro ]
22	Address:	Shop 23
23		Big Industrial Estate
24		SOME TOWN
25		NSW, 2222
26	Phone:	02 123-456
27	Fax:	026639-7944
Rearrange Data

 

[Hagbo]

Thank's so much, Peter! This worked a treat. Brilliant stuff!