excel vba split text

Question

Please be aware that I am working with a series of ~1000 line medical information databases. Due to the size of the databases, manual manipulation of the data is too time consuming. As such, I have attempted to learn VBA and code an Excel 2010 macro using VBA to help me accomplish parsing certain data. The desired output is to split certain characters from a provided string on each line of the database as follows:

99204 - OFFICE/OUTPATIENT VISIT, NEW

will need to be split into

Active Row Active Column = 99204 ActiveRow Active Column+3 = OFFICE/OUTPATIENT VISIT, NEW

I have researched this topic using Walkenbach's "Excel 2013: Power Programming with VBA" and a fair amount of web resources, including this awesome site, but have been unable to develop a fully-workable solution using VBA in Excel. The code for my current macro is:

Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
Cells(1, a + 3).Value = Trim(name(a))
Next a
End Sub

The code uses the "-" character as a delimiter to split the input string into two substrings (I have limited the output strings to 2, as there exists in some input strings multiple "-" characters). I have trimmed the second string output to remove leading spaces.

The trouble that I am having is that the output is being presented at the top of the activesheet, instead of on the activerow.

Thank you in advance for any help. I have been working on this for 2 days and although I have made some progress, I feel that I have reached an impasse. I think that the issue is somewhere in the

Cells(1, a + 3).Value = Trim(name(a))

code, specifically with "Cells()".

Thank you Conrad Frix!

Yah.. funny enough. Just after I post I have a brainstorm.. and modify the code to read:

Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
ActiveCell.Offset(0, 3 + a).Value = Trim(name(a))
Next a
End Sub

Not quite the colkumn1,column4 output that I want (it outputs to column3,column4), but it will work for my purpose.

Now I need to incorporate a loop so that the code runs on each successive cell in the column (downwards, step 1) skipping all bolded cells, until it hits an empty cell.

Solution 1

Modified answer to modified request. This will start on row 1 and continue until a blank cell is found in column A. If you would like to start on a different row, perhaps row 2 if you have headers, change the

i = 1

line to

i = 2

I added a check on the upper bound of our variant before doing the output writes, in case the macro is run again on already formatted cells. (Does nothing instead of erroring out)

Sub EasySplit()
Dim initialText As String
Dim i As Double
Dim name As Variant
i = 1
Do While Trim(Cells(i, 1)) <> ""
    If Not Cells(i, 1).Font.Bold Then

        initialText = Cells(i, 1).text
        name = Split(initialText, "-", 2)
        If Not UBound(name) < 1 Then
            Cells(i, 1) = Trim(name(0))
            Cells(i, 4) = Trim(name(1))
        End If
    End If
    i = i + 1
Loop
End Sub

Solution 2

just add a variable to keep track of the active row and then use that in place of the constant 1.

e.g.

Dim iRow as Integer =  ActiveCell.Row
For a = 0 To 1
     Cells(iRow , a + 3).Value = Trim(name(a))
Next a

Solution 3

Alternate method utilizing TextToColumns. This code also avoids using a loop, making it more efficient and much faster. Comments have been added to assist with understanding the code.

EDIT: I have expanded the code to make it more versatile by using a temp worksheet. You can then output the two columns to wherever you'd like. As stated in your original question, the output is now to columns 1 and 4.

Sub tgr()

    Const DataCol As String = "A"   'Change to the correct column letter
    Const HeaderRow As Long = 1     'Change to be the correct header row

    Dim rngOriginal As Range        'Use this variable to capture your original data

    'Capture the original data, starting in Data column and the header row + 1
    Set rngOriginal = Range(DataCol & HeaderRow + 1, Cells(Rows.Count, DataCol).End(xlUp))
    If rngOriginal.Row < HeaderRow + 1 Then Exit Sub 'No data

    'We will be using a temp worksheet, and to avoid a prompt when we delete the temp worksheet we turn off alerts
    'We also turn off screenupdating to prevent "screen flickering"
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    'Move the original data to a temp worksheet to perform the split
    'To avoid having leading/trailing spaces, replace all instances of " - " with simply "-"
    'Lastly, move the split data to desired locations and remove the temp worksheet

    With Sheets.Add.Range("A1").Resize(rngOriginal.Rows.Count)
        .Value = rngOriginal.Value
        .Replace " - ", "-"
        .TextToColumns .Cells, xlDelimited, Other:=True, OtherChar:="-"
        rngOriginal.Value = .Value
        rngOriginal.Offset(, 3).Value = .Offset(, 1).Value
        .Worksheet.Delete
    End With

    'Now that all operations have completed, turn alerts and screenupdating back on
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub

Solution 4

You can do this in a single shot without looping using the VBA equivalent of entering this formula, then taking values only

as a formula

=IF(NOT(ISERROR(FIND("-",A1))),RIGHT(A1,LEN(A1)-FIND("-",A1)-1 ),A1)

code

Sub Quicker()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
With rng1.Offset(0, 3)
    .FormulaR1C1 = "=IF(NOT(ISERROR(FIND(""-"",RC[-3]))),RIGHT(RC[-3],LEN(RC[-3])-FIND(""-"",RC[-3])-1 ),RC[-3])"
    .Value = .Value
End With
End Sub

View more solutions