Need Macro for transposing address in column to rows

[amitks]

Need Macro for transposing address in column to rows. Here is the example data:

Personal data removed per forum rules

The data is not consistent, have few or no blanks at times.

 

[Peter_SSs]

Welcome to the MrExcel board!

If we can assume the indication of the end of an address block is a cell ending with a space followed by 4-digits (postcode), then try this in a copy of your workbook.

Sub TransposeAddress()
  Dim a, b
  Dim bStartNew As Boolean
  Dim i As Long, j As Long, r As Long
  
  Const MaxRowsPerAddr As Long = 8  '<- Change if you think an addr could have more rows
  
  bStartNew = True
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 8)
  For i = 1 To UBound(a)
    If a(i, 1) <> "" Then
      If bStartNew Then
        r = r + 1
        j = 1
        b(r, j) = a(i, 1)
        bStartNew = False
      Else
        j = j + 1
        b(r, j) = a(i, 1)
        If Right(a(i, 1), 5) Like " ####" Then bStartNew = True
      End If
    End If
  Next i
  With Range("B1").Resize(r, MaxRowsPerAddr)
    .Value = b
    .EntireColumn.AutoFit
  End With
End Sub

 

[amitks]

Thanks a lot Peter for solving my problem.

I have another part of the problem where the end is not similar like the postcode in previous one.

Here is the data:

Personal data removed per forum rules

I used it with your macro but it returned error.

Could you please look into it?

Regards
Amit

Welcome to the MrExcel board!

If we can assume the indication of the end of an address block is a cell ending with a space followed by 4-digits (postcode), then try this in a copy of your workbook.

Sub TransposeAddress()
  Dim a, b
  Dim bStartNew As Boolean
  Dim i As Long, j As Long, r As Long
  
  Const MaxRowsPerAddr As Long = 8  '<- Change if you think an addr could have more rows
  
  bStartNew = True
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 8)
  For i = 1 To UBound(a)
    If a(i, 1) <> "" Then
      If bStartNew Then
        r = r + 1
        j = 1
        b(r, j) = a(i, 1)
        bStartNew = False
      Else
        j = j + 1
        b(r, j) = a(i, 1)
        If Right(a(i, 1), 5) Like " ####" Then bStartNew = True
      End If
    End If
  Next i
  With Range("B1").Resize(r, MaxRowsPerAddr)
    .Value = b
    .EntireColumn.AutoFit
  End With
End Sub

Personal data removed per forum rules

 

[amitks]

Hi Peter,

I have managed to add "2345" at the end of each block. Here is the example:

Personal data removed per forum rules

Thanks a lot Peter for solving my problem.

I have another part of the problem where the end is not similar like the postcode in previous one.

Here is the data:

Personal data removed per forum rules

I used it with your macro but it returned error.

Could you please look into it?

Regards
Amit

 

[Rick Rothstein]

I have managed to add "2345" at the end of each block. Here is the example:

Question... are the lines you posted that are shown in bold... are they also bold on your worksheet? If so, are they the only bold text in the column?

 

[amitks]

Here is the link to the file

Link to personal data removed per forum rules

 

[Peter_SSs]

1. Are those real addresses, email addresses & phone numbers? If so the owners may not be too pleased at having them in a forum like this where spammers regularly hunt for email addresses especially. Refer also #13 of the Forum Rules

2. You don't really need to add anything to mark the end of these new blocks because they all have a clear marking at the beginning instead: "Practitioners:"

3. I'm not entirely clear how you want these results presented. Please give small sample of varied dummy data and the expected result.

 

[amitks]

Here is the sample data

Personal data removed per forum rules

Thanks
Amit

 

[Peter_SSs]

1. Are those real addresses, email addresses & phone numbers? If so the owners may not be too pleased at having them in a forum like this where spammers regularly hunt for email addresses especially. Refer also #13 of the Forum Rules

You didn't answer the above question. I can remove the data from your posts if required.


Here I've disguised the data from an earlier post in case.

This should arrange your data even if not in a consistent order (apart from name being first) initially as follows
- first cell after "Practitioners:" goes to name column
- a cell only containing digits and numbers will go to mthe phone column
- a cell containing the "@" symbol to email
- a cell beginning with "www." to website.

Sub GetIt()
  Dim a, b
  Dim i As Long, c As Long, r As Long
  Dim s As String
  
  a = Range("A1", Range("A" & Rows.Count).End(xlUp)).Value
  ReDim b(1 To UBound(a), 1 To 4)
  For i = 1 To UBound(a)
    s = a(i, 1)
    If s <> "" Then
      If LCase(s) = "practitioners:" Then
        i = i + 1
        r = r + 1
        b(r, 1) = a(i, 1)
      Else
        Select Case True
          Case IsNumeric(Replace(s, " ", "")): c = 2
          Case InStr(s, "@"): c = 3
          Case Left(LCase(s), 4) = "www.": c = 4
          Case Else: c = 5
        End Select
        If c < 5 Then b(r, c) = s
      End If
    End If
  Next i
  With Range("E2").Resize(r, 4)
    .Value = b
    .EntireColumn.AutoFit
  End With
End Sub

Excel Workbook
	A	B	C	D	E	F	G	H
1	Practitioners:				Practitioner Name	Phone	email	website
2	alizabath Walkar (Mzotharajz)				alizabath Walkar (Mzotharajz)	03 1116 1041	contact@absolutabodzhaalth.com.au	www.absolutabodzhaalth.com.au
3	03 1116 1041				Simona Damoor (Mzotharajz)	03 1314 4446
4	contact@absolutabodzhaalth.com.au				Hazlaz Bottin (Mzotharajz)	03 1764 1341	mzownhaalth@hotmail.com	www.jhzsiosjot.com.au
5	www.absolutabodzhaalth.com.au
6	Practitioners:
7	Simona Damoor (Mzotharajz)
8	03 1314 4446
9
10	Practitioners:
11	Hazlaz Bottin (Mzotharajz)
12	03 1764 1341
13	mzownhaalth@hotmail.com
14	www.jhzsiosjot.com.au
15
Extract Data

 

[amitks]

Hi Peter,

Any luck with the solution?

Regards
Amit