Solved: Split up the word in a cell

[spartacus132]

Hi!

I am in need of some VBA functionality in Excel and having no prior experience at all in VBA, I am posting this here. Perhaps some can help me out here. Thanks in advance for any attempts to get me started or for any help you provide on this matter.

I have a list of words in Column A which need to be spilt up. For example if column A contains:

AccountIsParentInstitutionAccount
AccountIsPatient
AccountIsSuspenseAccount
AdjustmentQuantity
AdjustmentReasonCode
ILHCCCCContactPerson
ICDProcedureDBkey

The code should iterate through column A and take the word in a cell and split it up. It should then insert that word in Column B. To make things clearer, by using the above words as an example, column B should contain:

Account
Is
Parent
Institution
Patient
Suspense
Adjustment
Quantity
Reason
Code
ILHCCCC
Contact
Person
ICD
Procedure
DB
key

A word doesn’t need to be inserted again if it exists already. That is, if a word exits, then skip it. Also, if the word is all caps then the code should just insert the word "as is." In the above list, "ILHCCCC," "ICD" and "DB" are an example.

Thanks,
Anupam

[Bob Phillips]

Sub Test()
Dim iLastRow As Long
Dim i As Long, j As Long
Dim iEnd As Long
Dim iStart As Long
Dim sTmp As String
Dim iValue As Long
Dim aryValues

Application.ScreenUpdating = False
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
ReDim aryValues(1 To 1)
iValue = 0
For i = 1 To iLastRow
iStart = 1
For j = 2 To Len(Cells(i, "A").Value & "Z")
If Asc(Mid(Cells(i, "A").Value & "Z", j, 1)) >= 65 And _
Asc(Mid(Cells(i, "A").Value & "Z", j, 1)) <= 90 Then
sTmp = Mid(Cells(i, "A").Value, iStart, j - iStart)
If IsError(Application.Match(sTmp, aryValues, 0)) Then
iValue = iValue + 1
ReDim Preserve aryValues(1 To iValue)
aryValues(iValue) = sTmp
End If
iStart = j
End If
Next j
Next i
Range("A1").Resize(UBound(aryValues)) = Application.Transpose(aryValues)
Application.ScreenUpdating = True
End Sub

[Zack Barresse]

Cross-post http://www.puremis.net/excel/cgi-bin/yabb/YaBB.pl?num=1154960190/1#1

Good thing you mentioned that at JMT Bob, I was almost complete with another solution, although it's a little longer than yours (too many loops), but it runs fast enough I guess. I was almost done anyway, so I just finished and I'll post it ..

Sub SplitWords()

'## Dimension variables
Dim ws As Worksheet, c As Range, rngSplit As Range
Dim arrCell() As Variant, arrTmp() As Long
Dim i As Long, iCnt As Long
Dim objDict As Object, dicElm As Variant

'## Set variables
Set ws = Sheets("Sheet1")
Set rngSplit = ws.Range("A3", ws.Cells(ws.Rows.Count, 1).End(xlUp))
Set objDict = CreateObject("Scripting.Dictionary")

'## Iterate cells, split individually, add to collection
For Each c In rngSplit

'## Go through each character, looking for caps
iCnt = 0
For i = 1 To Len(c.Value)
If UCase(Mid(c.Value, i, 1)) = Mid(c.Value, i, 1) Then
ReDim Preserve arrTmp(0 To iCnt)
arrTmp(iCnt) = i
iCnt = iCnt + 1
End If
Next i
ReDim Preserve arrCell(0 To UBound(arrTmp))
'## Set each word to part of an array
For i = LBound(arrTmp) To UBound(arrTmp)
If i = UBound(arrTmp) Then
arrCell(i) = Right(c.Value, Len(c.Value) - arrTmp(i) + 1)
Else
arrCell(i) = Mid(c.Value, arrTmp(i), arrTmp(i + 1) - arrTmp(i))
End If
Next i
'## Set unique values
For i = LBound(arrCell) To UBound(arrCell)
If Not objDict.Exists(arrCell(i)) Then
objDict.Add arrCell(i), arrCell(i)
End If
Next i
'## Reset arrays for next cell
ReDim arrTmp(0)
ReDim arrCell(0)

Next c

'## Iterate through dictionary object
i = 3
For Each dicElm In objDict
ws.Cells(i, 2).Value = dicElm
i = i + 1
Next dicElm

End Sub

Oh, and just for clarification Spartacus132, the list you show is incomplete with uniques.

[spartacus132]

xld and firefytr,
Thanks so much for your quick response. However, there might be
instances (which i forgot to include in my original post), where a word might
be like--"PatientAlternateIDDBKey." In such a case, i hope that the code can
break down "PatientAlternateIDDBKey" as:
Patient
Alternate
IDDB
Key

Also, there might be a case where the word might be
"HEALTH_REGISTRATION_ID," in such a case i hope the code can insert this word
"as is." Such a word need not be split up.

[mdmackillop]

This seems to work on your samples, but no guarantees beyond that


Option Explicit
Sub Splitting()
Dim w As String, wd As String, MyArray(), cel As Range
Dim i As Long, j As Long, k As Long, Rw As Long
Dim d, a
Set d = CreateObject("Scripting.Dictionary")
For Each cel In Range("A1:" & [A1].End(xlDown).Address)
ReDim MyArray(10)
w = cel
j = 1
MyArray(0) = 0
For i = 1 To Len(w) - 2
If Asc(Mid(w, i, 1)) > 96 And Asc(Mid(w, i + 1, 1)) < 96 _
And Asc(Mid(w, i + 2, 1)) > 96 Then
MyArray(j) = i
j = j + 1
End If

If Asc(Mid(w, i, 1)) < 96 And Asc(Mid(w, i + 1, 1)) < 96 _
And Asc(Mid(w, i + 2, 1)) > 96 Then
MyArray(j) = i
j = j + 1
End If

If Asc(Mid(w, i, 1)) > 96 And Asc(Mid(w, i + 1, 1)) < 96 _
And Asc(Mid(w, i + 2, 1)) < 96 Then
MyArray(j) = i
j = j + 1
End If
Next


For k = 1 To j - 1
wd = Left(w, MyArray(k) - MyArray(k - 1))
On Error Resume Next
d.Add wd, wd
w = Right(w, Len(w) - (MyArray(k) - MyArray(k - 1)))
Next
d.Add w, w
Next

a = d.Items
For i = 0 To d.Count - 1
Cells(i + 1, 2) = a(i)
Next
End Sub


Your original data included ICDProcedureDBkey. "key" will not be correctly handled if the capitalisation is incorrect. - GIGO

[spartacus132]

You guys just saved me from manually splitting up 2000+ words.

Thanks for answering promptly. The response time and the solution was excellent.

Grateful,
Anupam

[mdmackillop]

Hi Zack,
In regard to my use of the Dictionary object, I use an intermediate variable "a" as per the help file example. Any idea why the code doesn't work without it?

In the following, tmp1 returns a value, but tmp2 is Empty

Dim tmp1, tmp2
a = d.Items
tmp1 = a(0)
tmp2 = d.Items(0)

[mdmackillop]

Hi Anupam,
Glad it worked out.
Regards
MD

[Bob Phillips]

Hi Zack,
In regard to my use of the Dictionary object, I use an intermediate variable "a" as per the help file example. Any idea why the code doesn't work without it?

In the following, tmp1 returns a value, but tmp2 is Empty

Dim tmp1, tmp2
a = d.Items
tmp1 = a(0)
tmp2 = d.Items(0)



Presumably it is beacuse the Dictionary is not a collectrion, so Itemns is not the collection of items but a method by which to retrive the items into an array.

[Zack Barresse]

I would presume the same as Bob. I always use a variant variable to loop through the dictionary object when retreiving values. I don't think the dictionary object has an index for it's Items property, hence being unable to interact with it by an index number in a traditional fashion; I think they're more of objects than values.

[mdmackillop]

Thanks both.

[Bob Phillips]

I would presume the same as Bob. I always use a variant variable to loop through the dictionary object when retreiving values. I don't think the dictionary object has an index for it's Items property, hence being unable to interact with it by an index number in a traditional fashion; I think they're more of objects than values.

It's an Items method Zack, not Property. That is the key I believe.

[Zack Barresse]

Sorry, was thinking method.. :doh: