A Simple Alphanumeric Splitting Problem

[kale_81]

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.

It reads something like this:

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

 

[jindon]

Hi

vba

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]

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]

Welcome to the board!

What version of Excel are you running?

 

[jindon]

Hi
try
change

txt = Replace(r.Text, Chr(32), "")

to

txt = application.substitute(r.Text, Chr(32), ""):

 

[kale_81]

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]

Hummmm

97 is always aproblem for me...

try this one

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]

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]

OK

do you want to change it to

If n=0 then

 

[kale_81]

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