Extract Alpha Numeric data VBA

[decadence]

Hi, I am trying to split Alpha Numeric data into separate columns but not having any luck. Can someone Help with this.

What I would like it to look like

Reference
A30	A	30
A30_1	A	_	1
A30_1_2	A	_	1	_	2
A_30	A	_	30
A_30_1	A	_	30	_	1
A_30_1_2	A	_	30	1	_	2

<tbody>
</tbody>

 

[wideboydixon]

Public Sub ExtractAlphaNumeric()

Dim lastRow As Long
Dim thisRow As Long
Dim nextCol As Long
Dim currentGroup As String
Dim currentType As Long
Dim thisType As Long
Dim thisChar As Long

' Get the last row
lastRow = Cells(Rows.Count, 1).End(xlUp).Row

' Process all rows
For thisRow = 2 To lastRow
    ' Next column to enter a value
    nextCol = 2

    ' Nothing in the current group or type
    currentGroup = ""
    currentType = 0
    
    ' Look at all characters in the string
    For thisChar = 1 To Len(Cells(thisRow, 1).Value)
        ' Determine the "type" of character
        Select Case UCase$(Mid$(Cells(thisRow, 1).Value, thisChar, 1))
            Case "A" To "Z"
                thisType = 1
            Case "0" To "9"
                thisType = 2
            Case Else
                thisType = 3
        End Select
        
        ' Have we changed types?
        If currentType <> thisType Then
            ' Do we have something in the current group?
            If currentGroup <> "" Then
                ' Populate the next column with the current group
                Cells(thisRow, nextCol).Value = currentGroup
                currentGroup = ""
                nextCol = nextCol + 1
            End If
        End If
        
        ' Accumulate the character into the current group and set the group type
        currentGroup = currentGroup & Mid$(Cells(thisRow, 1).Value, thisChar, 1)
        currentType = thisType
    Next thisChar
    
    ' Anything remaining needs to be populated into the next column
    If currentGroup <> "" Then Cells(thisRow, nextCol).Value = currentGroup
Next thisRow

End Sub

WBD

 

[decadence]

This works Perfectly, Thank you

 

[Rick Rothstein]

This works Perfectly, Thank you

Here is another macro that you may want to consider...

[table="width: 500"]
[tr]
	[td]Sub ExtractAlphaNumeric()
  Dim X As Long, Cell As Range, Txt As String, Data As Variant
  Data = Range("A2", Cells(Rows.Count, "A").End(xlUp))
  For Each Cell In Range("A2", Cells(Rows.Count, "A").End(xlUp))
    Txt = Cell.Value
    For X = Len(Txt) - 1 To 1 Step -1
      If Mid(Txt, X, 2) Like "[A-Za-z]#" Or Mid(Txt, X, 2) Like "#[A-Za-z]" Then Txt = Application.Replace(Txt, X + 1, 0, "_")
    Next
    Cell.Value = Replace(Txt, "_", "|_|")
  Next
  Range("A2", Cells(Rows.Count, "A").End(xlUp)).TextToColumns Range("B1"), xlDelimited, , , False, False, False, False, True, "|", Array(1, 4)
  Range("A2").Resize(UBound(Data)) = Data
End Sub[/td]
[/tr]
[/table]

 

[decadence]

Hi Rick, your code works great except when cell values that contain no underscores will end up having them once split out, so A30 will split out to A _ 30