UDF to Split Text String

cdrhodes · #1 01-27-2010, 11:25 AM

I am trying to take data from a table in a pdf. and transfer it to an excel spreadsheet that I will then add to a GIS database. Two different types of data are presented in 2 different formats. I need to remove unnecessary data from each format while maintaining the necessary data and splitting the necessary data into separate columns. Here are the two examples:

1) This may be easier because the two pieces of data I need are always the first and last pieces of data. In some cases there is more data in the cell than others including other numbers. I have included the two primary examples of how it appears below along with examples of how the data should appear afterwards.

(Data in 2 rows/1column)
BP Borrow pits 72.00
FuB Fuquay fine sand, 0 to 6 percent slopes 114.00

(Remaining data in 2 rows/2 columns, Text and numbers in different columns)
BP 72
FuB 114

So you can see I'm splitting BP and 72 into separate columns and deleting "Borrow pits". In the second example I'm splitting FuB and 114 into separate columns and deleting "Fuquay fine sand, 0 to 6 percent slopes".

2) In this one I need to do the same but the placement and type of data is different. The first part is the same. I need to retain the code at the beginning of the string in the 1st column. In the second column I just need whether it is Very Limited, Somewhat Limited, or Not Limited. Here are three examples of data strings. Each would be in a single cell.

(Data in 3 rows/1 column)
BP Borrow pits Very limited Udorthents 0.9
BrA Brogdon loamy sand, 0 to 2 percent slopes Not limited Brogdon 1
Ca Cantey loam Somewhat limited Cantey 1

Here's how the resulting data would look:

(Remaining data in 3 rows/2 columns, data split between code and very, not or somewhat limited)

BP Very Limited
BrA Not Limited
Ca Somewhat Limited

Note: I could use a numeric code (1,2,3) for Very Limited, Not Limited, and Somewhat Limited as I'll eventually have to convert it to that anyway if that makes it any easier.

Thanks in advance for any help you can provide.

**Richard Buttrey** · #2 01-27-2010, 11:33 AM

Hi, and welcome to the forum.

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

JBeaucaire · #3 01-27-2010, 12:30 PM

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

**Leith Ross** · #4 01-28-2010, 02:40 PM

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

Welcome to the Excel Forum

Forum Statistics