Thread: UDF to Split Text String

Hi, and welcome to the forum.

An attached workbook with a few examples of the results you expect is worth a thousand words.

This aren't UDFs, they are reformatting macros. Run this on a copy of your values in column A and see if they do what you wish.

Code:

Option Explicit
Option Compare Text

Sub ParseDataValue()
'Author:    Jerry Beaucaire
'Date:      1/27/2010
'SUMMARY:   Reduce text strings to specific values
Dim LR As Long, i As Long, v As Long
Dim RNG As Range, MyArr, Vals

LR = Range("A" & Rows.Count).End(xlUp).Row
Set RNG = Range("A:A").SpecialCells(xlCellTypeConstants)
MyArr = Application.WorksheetFunction.Transpose(RNG.Value)

    For i = 1 To LR
        Vals = Split(MyArr(i), " ")
        Cells(i, "A") = Vals(0)
        Cells(i, "B") = Format(Vals(UBound(Vals)), "0.00")
    Next i

Columns("B:B").NumberFormat = "0.00"
Columns.AutoFit
End Sub

Sub ParseDataSTATUS()
'Author:    Jerry Beaucaire
'Date:      1/27/2010
'SUMMARY:   Reduce text strings to specific status report
Dim LR As Long, i As Long
Dim RNG As Range, MyArr

LR = Range("A" & Rows.Count).End(xlUp).Row
Set RNG = Range("A:A").SpecialCells(xlCellTypeConstants)
MyArr = Application.WorksheetFunction.Transpose(RNG.Value)

    For i = 1 To LR
        Cells(i, "A") = Left(MyArr(i), InStr(MyArr(i), " ") - 1)
        
        If InStr(MyArr(i), "Very Limited") > 0 Then
            Cells(i, "B") = "Very Limited"
        ElseIf InStr(MyArr(i), "Not Limited") > 0 Then
            Cells(i, "B") = "Not Limited"
        ElseIf InStr(MyArr(i), "Somewhat Limited") > 0 Then
            Cells(i, "B") = "Somewhat Limited"
        End If

    Next i

Columns.AutoFit
End Sub

Hello cdrhodes,

Welcome to the Forum!

If you have a large amount of data to parse then this solution will provide you with fast processing. This macro looks at the data on "Sheet1" column "A" and parses the strings. The parsed data is copied to "Sheet2" starting in cells A1 and B1. You can change the worksheet names, starting cell of the source sheet and the starting row of the destination sheet. These are marked in the code in red.

Code:

Sub ParseData()

  Dim Cell As Range
  Dim DstWks As Worksheet
  Dim RegExp As Object
  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  Dim SrcWks As Worksheet
  Dim TestPat1 As String
  Dim TestPat2 As String
  Dim Text As String
  
      Set SrcWks = Worksheets("Sheet1")
      Set DstWks = Worksheets("Sheet2")
      
      R = 1   'Starting row on Destination Worksheet

     'Find the end of column "A" on "Sheet1"      
      Set Rng = SrcWks.Range("A1")
      Set RngEnd = SrcWks.Cells(Rows.Count, Rng.Column).End(xlUp)
      Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, SrcWks.Range(Rng, RngEnd))
      
        Set RegExp = CreateObject("VBScript.RegExp")
        RegExp.IgnoreCase = True
      
       'Test the start and end of the text for a word and a 2 place decimal number
        TestPat1 = "(^\w+\s)(.+)(\s\d+\.\d\d\s*$)"
      
       'Test the start for a word and for the following phrases:
       '  Not Limited, Somewhat Limited, Very Limited
        TestPat2 = "(^\w+\s)(.*)(Not\sLimited|Somewhat\sLimited|Very\sLimited)(.*)"
       
          For Each Cell In Rng
            Test = True
            Text = Cell.Value
            RegExp.Pattern = TestPat1
              If Test = True Then GoSub TestData
            RegExp.Pattern = TestPat2
              If Test = True Then GoSub TestData
          Next Cell
          
   'Release the object reference and memory
    Set RegExp = Nothing
    Exit Sub
    
TestData:
    If RegExp.Test(Text) = True Then
       Test = False
       DstWks.Cells(R, 1) = RegExp.Replace(Text, "$1")
       DstWks.Cells(R, 2) = RegExp.Replace(Text, "$3")
       R = R + 1
    End If
  Return
  
End Sub

Adding the Macro
1. Copy the macro above pressing the keys CTRL+C
2. Open your workbook
3. Press the keys ALT+F11 to open the Visual Basic Editor
4. Press the keys ALT+I to activate the Insert menu
5. Press M to insert a Standard Module
6. Paste the code by pressing the keys CTRL+V
7. Make any custom changes to the macro if needed at this time.
8. Save the Macro by pressing the keys CTRL+S
9. Press the keys ALT+Q to exit the Editor, and return to Excel.

To Run the Macro...
To run the macro from Excel, open the workbook, and press ALT+F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.