vba to extract address

[Fixminx]

Hi,

I am fairly new to vba and am currently stuck on what is probably a simple task. I have a set of addresses on a ssheet in one column but they are seperated by a return for each line of the address ie:
Jo Bloggs
One Street
Anytown
AnyCounty

I need to split the address into seperate columns for each line of the address (there are several hundred addresses)

I found this code which works perfectly fine when I select an address and click a button to run the sub:

[SIZE=3]Sub SplitText()

Dim str() As String

        For Each c In ActiveCell.CurrentRegion.Cells
    
          If Len(ActiveCell.Value) Then      ' CHECK IF THE ACTIVE CELL IS NOT EMPTY.
    
             ' SPLIT THE ACTIVE CELL'S VALUE WITH LINE FEED (vbLf).
              str = VBA.Split(ActiveCell.Value, vbLf)
        
             ' REARRANGE TEXT TO MULTIPLE COLUMNS.
              ActiveCell.Resize(1, UBound(str) + 1).Offset(0, 1) = str
         End If
        Next
            
End Sub[/SIZE]

But however I try to loop this it only ever works for the first address and then stops. I have tried looping for each cell in a selection, for each cell in a set range (For each cell in Range ("A2:A500")) and even leaving the working sub alone and using a second to Call the sub for each cell in the range, nothing seems to work.

Ideally I would like to select a range in the worksheet that contains the addresses, assign a macro to a button and have all addresses extract when button is clicked.

Any help greatly appreciated

 

[kweaver]

Are the lines separated by an Alt+Enter [ Char(10) ] ?
If so, why not fill this down:

=TEXTSPLIT(A2,CHAR(10))

If you want it to be VBA, just wrap a loop around it:

Sub SplitText()

Dim str() As String, lr, i As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lr  ' assumes the addresses begin in A1
  Cells(i, "A").Select
        For Each c In ActiveCell.CurrentRegion.Cells
    
          If Len(ActiveCell.Value) Then      ' CHECK IF THE ACTIVE CELL IS NOT EMPTY.
    
             ' SPLIT THE ACTIVE CELL'S VALUE WITH LINE FEED (vbLf).
              str = VBA.Split(ActiveCell.Value, vbLf)
        
             ' REARRANGE TEXT TO MULTIPLE COLUMNS.
              ActiveCell.Resize(1, UBound(str) + 1).Offset(0, 1) = str
         End If
        Next
Next i
End Sub

 

[DanteAmor]

Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.

Ideally I would like to select a range

For that, try the following code, select the cells and the result will be in the next cells to the right.

Sub SplitText()
  Dim c As Range
  Dim str() As String
 
  For Each c In Selection
    If Len(c.Value) Then      ' CHECK IF THE ACTIVE CELL IS NOT EMPTY.
      ' SPLIT THE ACTIVE CELL'S VALUE WITH LINE FEED (vbLf).
      str = VBA.Split(c.Value, vbLf)
      ' REARRANGE TEXT TO MULTIPLE COLUMNS.
      c.Resize(1, UBound(str) + 1).Offset(0, 1) = str
    End If
  Next
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[Georgiboy]

Another formula option with no need to drag down, just select the range:

Book1
	A	B	C	D	E	F
1	Address
2	Jo Bloggs One Street Anytown AnyCounty UK	Jo Bloggs	One Street	Anytown	AnyCounty	UK
3	Jo Bloggs One Street Anytown AnyCounty	Jo Bloggs	One Street	Anytown	AnyCounty
4	Jo Bloggs One Street Anytown	Jo Bloggs	One Street	Anytown
5	Jo Bloggs One Street Anytown AnyCounty	Jo Bloggs	One Street	Anytown	AnyCounty
6	Jo Bloggs One Street Anytown AnyCounty UK	Jo Bloggs	One Street	Anytown	AnyCounty	UK
Sheet1

Cell Formulas
Range	Formula
B2:F6	B2	=LET(data,A2:A6, c, MAX(BYROW(data,LAMBDA(x,LEN(x)-LEN(SUBSTITUTE(x,CHAR(10),""))+1))), xml, "<t><s>" & SUBSTITUTE(data,CHAR(10),"</s><s>") & "</s></t>", f,FILTERXML(xml,"//s[" & SEQUENCE(,c) & "]"), MAP(f,LAMBDA(x,IF(ISERROR(x),"",x))))
Dynamic array formulas.

 

[Fixminx]

Are the lines separated by an Alt+Enter [ Char(10) ] ?
If so, why not fill this down:

=TEXTSPLIT(A2,CHAR(10))

If you want it to be VBA, just wrap a loop around it:

Sub SplitText()

Dim str() As String, lr, i As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To lr  ' assumes the addresses begin in A1
  Cells(i, "A").Select
        For Each c In ActiveCell.CurrentRegion.Cells
   
          If Len(ActiveCell.Value) Then      ' CHECK IF THE ACTIVE CELL IS NOT EMPTY.
   
             ' SPLIT THE ACTIVE CELL'S VALUE WITH LINE FEED (vbLf).
              str = VBA.Split(ActiveCell.Value, vbLf)
       
             ' REARRANGE TEXT TO MULTIPLE COLUMNS.
              ActiveCell.Resize(1, UBound(str) + 1).Offset(0, 1) = str
         End If
        Next
Next i
End Sub

Thank you. I did look at TEXTSPLIT but tbh as the data was a download I didnt consider the seperator was Alt+Enter but that actually works just fine. I ended up still doing it as a macro and added to my personal macros for future use but will be using TextSplit more now.

 

[Fixminx]

Welcome to the MrExcel forum. Please accept my warmest greetings and sincere hope that all is well.




For that, try the following code, select the cells and the result will be in the next cells to the right.

Sub SplitText()
  Dim c As Range
  Dim str() As String
 
  For Each c In Selection
    If Len(c.Value) Then      ' CHECK IF THE ACTIVE CELL IS NOT EMPTY.
      ' SPLIT THE ACTIVE CELL'S VALUE WITH LINE FEED (vbLf).
      str = VBA.Split(c.Value, vbLf)
      ' REARRANGE TEXT TO MULTIPLE COLUMNS.
      c.Resize(1, UBound(str) + 1).Offset(0, 1) = str
    End If
  Next
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

Thank you. This actually works just how I wanted and even better I can see where I was going wrong. I had done exactly the same by adding Dim c as Range and For each c in selection but at the end I had typed Next c instead of simply Next.

 

[Peter_SSs]

Welcome to the MrExcel board!

I didnt consider the seperator was Alt+Enter but that actually works just fine.

In that case why not just select the column and do a manual Text To Columns?

Or if it must be a macro & the data is in column A, still use Text To Columns and there should be no need to do them one row at a time.

Sub Address_Split()
  Columns("A").TextToColumns Range("B1"), xlDelimited, , , False, False, False, False, True, Chr(10)
End Sub

 

[Peter_SSs]

can see where I was going wrong. I had done exactly the same by adding Dim c as Range and For each c in selection but at the end I had typed Next c instead of simply Next.

Next c is exactly the same as just Next in that circumstance, so if one code was working and one not, there must have been something else different between them.

Ideally I would like to select a range in the worksheet that contains the addresses

I had missed that. The change to my one-liner is

Sub Address_Split_v2()
  Selection.TextToColumns Selection.Offset(, 1), xlDelimited, , , False, False, False, False, True, Chr(10)
End Sub