# A Simple Alphanumeric Splitting Problem

#### kale_81

##### New Member
Hello all:

I've got to say i'm quite impressed with this forum, and have learned much from the members here in my 6 months lurking here. For that, I thank you all truly. I have, however, come across a problem I cannot seem to solve, and must ask for some help.

I'm trying to split a single alphanumeric column into individual cells. I've been working on making it easy so that I can highlight the individual column that this information resides in, then be able to run a macro to split it up into the next several columns.

JK63 HD1
JK4HD1
ZY356
DJ 3458 HD2

I'd like it to be able to read:

A........B.......C........D

JK.......63.....HD......1
JK.......4.......HD......1
ZY......356
DJ......3458...HD......2

The idea is to have the first two letters in the first column, followed by the numerical string (1-4 numbers long depending) in the next column, followed finally by the next set of letters, and the single number after that. The catch is that the original letter/numbers may or may not have spaces between them, and more importantly, the first series of numbers goes from 1 all the way to 9999, meaning that the forumla would have to account for this somehow.

I've tried altering Mr. Pearson's telephone and name parsing code to make this work, but have only met failure time and again. Does anyone have any input they might give me to make something seemingly so simple work? I'd hate to have to modify all 80,000 lines manually. Thanks much, Chris

### Excel Facts

What is the shortcut key for Format Selection?
Ctrl+1 (the number one) will open the Format dialog for whatever is selected.

#### jindon

##### MrExcel MVP
Hi

vba
Code:
``````Sub test()
Dim r As Range, txt As String, s As String, a()
Dim i As Long, n As Long
With ActiveSheet
For Each r In .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
If Not IsEmpty(r) Then
txt = Replace(r.Text, Chr(32), ""): i = 1
Do While Len(Trim(txt)) > 0
x = Mid\$(txt, i, 1)
Select Case x
Case 0 To 9
y = Val(Mid(txt, i))
n = n + 1
If Len(s) > 0 Then n = n + 1
ReDim Preserve a(1 To n)
On Error Resume Next
a(n - 1) = s
Err.Clear
a(n) = y
txt = Right\$(txt, Len(txt) - Len(s) - Len(y))
i = 0
y = Empty: s = Empty
Case Else
s = s & Mid\$(txt, i, 1)
End Select
i = i + 1
If i > Len(txt) Then Exit Do
Loop
End If
r.Offset(, 1).Resize(, UBound(a)) = a: n = Empty
Erase a
Next
End With
End Sub``````

#### kale_81

##### New Member
jindon, I think this is what I am looking for. Thanks so much for your time. I seem to be getting an error, however, i'm not sure if because of something i'm doing.

I continue to get "compile error - sub or function not defined" when I paste this into a new module and then try to run it? It continually highlights the word "replace" in line 7. Is there something else I need to do?

#### Zack Barresse

##### MrExcel MVP
Welcome to the board!

What version of Excel are you running?

#### jindon

##### MrExcel MVP

Hi
try
change
Code:
``txt = Replace(r.Text, Chr(32), "")``
to
Code:
``txt = application.substitute(r.Text, Chr(32), ""):``

#### kale_81

##### New Member
I wasn't sure it would make a difference, but I am running excel 97' leave it up to the government to not want to update in 8 years.

Thanks for the help again, I tried replacing the line, and now it is saying "Runtime error "9": Subscript out of range

I'm inferring at this point that my ancient excel file must be causing some of these problems.

#### jindon

##### MrExcel MVP

Hummmm

97 is always aproblem for me...

try this one
Code:
``````Sub test()
Dim r As Range, txt As String, s As String, a()
Dim i As Long, n As Long
With ActiveSheet
For Each r In .Range("a1", .Range("a" & .Rows.Count).End(xlUp))
If Not IsEmpty(r) Then
txt = Application.Substitute(r.Text, Chr(32), ""): i = 1
Do While Len(Trim(txt)) > 0
x = Mid\$(txt, i, 1)
Select Case x
Case 0 To 9
y = Val(Mid(txt, i))
n = n + 1
If Len(s) > 0 Then n = n + 1
ReDim Preserve a(1 To n)
On Error Resume Next
a(n - 1) = s
Err.Clear
a(n) = y
txt = Right\$(txt, Len(txt) - Len(s) - Len(y))
i = 0
y = Empty: s = Empty
Case Else
s = s & Mid\$(txt, i, 1)
End Select
i = i + 1
If i > Len(txt) Then Exit Do
Loop
End If
If LBound(a) = 0 Then
r.Offset(, 1) = r
Else
r.Offset(, 1).Resize(, UBound(a)) = a: n = Empty
Erase a
End If
s = Empty
Next
End With
End Sub``````

#### kale_81

##### New Member
Yeah, still the same error: Runtime error "9": script out of range.

It does point to line 30, however:

If LBound(a) = 0 Then

I didn't think it would be so complicated. Sorry for the trouble!

#### jindon

##### MrExcel MVP
OK

do you want to change it to

If n=0 then

#### kale_81

##### New Member
Hmm. Now it's giving me "Runtime error 13" Type Mismatch?

Replies
6
Views
148
Replies
1
Views
102
Replies
4
Views
92
Replies
3
Views
266
Replies
9
Views
161