View Single Post
  #7   Report Post  
Posted to microsoft.public.excel.programming
giddne giddne is offline
external usenet poster
 
Posts: 4
Default Rearranging data in a text cell

Thanks T-Rex, I'll give it a try after the holiday. You guys are the best.
If you're ever in Atlanta I'll buy you a Heineken and we can listen to
"bang-a-gong"
David

"T-®ex" wrote:


Hi David! Here's a custom version of 'Text To Columns' tailored to your
needs.
Just paste the code below to a Module (in the VBA editor). The first
subroutine (CustomTextToColumns) is the main sub and the 2nd
(TestCustomTextToColumns) is the test sub.
To use the test sub, just add a button (or any other control) to your
sheet and assign its macro to 'TestCustomTextToColumns'. Then, select a
number or rows (single column!) and click the button. If everything's ok
then you should see the first 3 tokens of your data pasted
to the neighboring cells.


Code:
--------------------
Option Explicit

'SelectedCell is the cell that contains the names to be split
'Delimiter determines how the names should be split, e.g., split by the space character...
'TokenLimit is the limit you specify (3 - only the first three parts)
'Destination is the starting cell where the split values are placed.
Sub CustomTextToColumns(ByVal SelectedCell As Range, ByVal Delimiter As String, ByVal TokenLimit As Integer, ByVal Destination As Range)
Dim StringTokens As Variant
Dim NumTokens As Integer
Dim TokenIndex As Integer
Dim Limit As Integer
Dim LowerBound As Long

StringTokens = Split(SelectedCell.Value, Delimiter)
LowerBound = LBound(StringTokens)
NumTokens = UBound(StringTokens) - LowerBound + 1

If NumTokens < TokenLimit Then
Limit = NumTokens - 1
Else
Limit = TokenLimit - 1
End If

For TokenIndex = LowerBound To Limit
Destination.Offset(0, TokenIndex - LowerBound).Value = StringTokens(TokenIndex)
Next TokenIndex
End Sub

'This test splits the data in the selected cells and puts
'the first 3 tokens (parts) of the data to the cell to the
'right of the selection.
Sub TestCustomTextToColumns()
Const rtLimit As Integer = 3 'only interested in the first three...
Const rtDelimiter As String = " " 'separate names by the space character

Dim TheSelection As Range
Set TheSelection = Selection

If TheSelection.Columns.Count < 1 Then
MsgBox "Custom Text To Columns can only convert one column at a time." & vbCrLf & _
"The range may be many rows tall but no more than one column wide." & vbCrLf & _
"Try again by selecting cells in one column only.", vbCritical, "Error"
Else
Dim ItemIndex As Long
Dim ItemCount As Long

ItemCount = TheSelection.Count

For ItemIndex = 1 To ItemCount
CustomTextToColumns TheSelection.Item(ItemIndex), rtDelimiter, rtLimit, TheSelection.Item(ItemIndex).Offset(0, 1)
Next ItemIndex
End If
End Sub
--------------------


:)

giddne Wrote:
I have cells with names to use in direct mail. The current format could
be
many variations but I only need the first 3 names initials etc. such as
John
Doe or John W Doe. I am not interested in anything after that.
Putting it
in 3 separate cells would be ideal but 1 or 2 would also be
acceptable.

Current formats include all of these:
Doe John
Doe John W
Doe John W JR
Doe John W & Doe Jane R

Appreciate your help. Love this site!!
David



--
T-®ex
------------------------------------------------------------------------
T-®ex's Profile: http://www.excelforum.com/member.php...o&userid=26572
View this thread: http://www.excelforum.com/showthread...hreadid=401649