Delimiting across multiple columns

[eidde1]

Hi
I am interested if a macro exists that will delimit across multiple columns in Excel. My data is as follows and I wish to split the antibiotic from the letter which is 23 characters from the beginning of the column. An example of the data is as follows, I am unsure how to put borders in but the first example Amoxicillin and R is in same cell in Excel, R is 23 Characters from the beginning of the cell. On conversion Amoxicillin and R are in two seperate cells.

Amoxicillin R Vancomycin R Teicoplanin R
Amoxicillin R Nalidixic acid s Teicoplanin s
Amoxicillin R Vancomycin s Teicoplanin s
Amoxicillin R Vancomycin R Teicoplanin S
Amoxicillin S
Amoxicillin R Vancomycin S Nitrofurantoin S
Amoxicillin R Vancomycin s Teicoplanin s
Nitrofurantoin S Vancomycin s
Amoxicillin S Vancomycin s Teicoplanin s

Convert to

Amoxicillin R Vancomycin R Teicoplanin R
Amoxicillin R Nalidixic acid s Teicoplanin s
Amoxicillin R Vancomycin s Teicoplanin s
Amoxicillin R Vancomycin R Teicoplanin S
Amoxicillin S
Amoxicillin R Vancomycin S Nitrofurantoin S
Amoxicillin R Vancomycin s Teicoplanin s
Nitrofurantoin S Vancomycin s
Amoxicillin S Vancomycin s Teicoplanin s


I hope this is clear

Many thanks
Eddie

 

[Claus Busch]

Hi,

Am Tue, 10 Dec 2013 07:24:28 -0800 (PST) schrieb (e-mail address removed):

Amoxicillin R Vancomycin R Teicoplanin R
Amoxicillin R Nalidixic acid s Teicoplanin s
Amoxicillin R Vancomycin s Teicoplanin s
Amoxicillin R Vancomycin R Teicoplanin S
Amoxicillin S
Amoxicillin R Vancomycin S Nitrofurantoin S
Amoxicillin R Vancomycin s Teicoplanin s
Nitrofurantoin S Vancomycin s
Amoxicillin S Vancomycin s Teicoplanin s

try:

Sub SplitString()
Dim LCol As Integer
Dim i As Integer

With ActiveSheet
LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column

For i = 2 To LCol * 2 Step 2
.Columns(i).Insert
.Columns(i - 1).TextToColumns Destination:=.Cells(1, i - 1), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, _
Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Next
End With
End Sub


Regards
Claus B.

 

[eidde1]

Hi,



Am Tue, 10 Dec 2013 07:24:28 -0800 (PST) schrieb :







try:



Sub SplitString()

Dim LCol As Integer

Dim i As Integer



With ActiveSheet

LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column



For i = 2 To LCol * 2 Step 2

.Columns(i).Insert

.Columns(i - 1).TextToColumns Destination:=.Cells(1, i - 1), _

DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _

ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, _

Comma:=False, Space:=True, Other:=False, FieldInfo _

:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

Next

End With

End Sub





Regards

Claus B.

--

Win XP PRof SP2 / Vista Ultimate SP2

Office 2003 SP2 /2007 Ultimate SP2

Hi Claus
Thanks for this unfortunately it splits column A over 2 columns but but not original columns B and C. I showed 3 columns of data but sometimes there are up to 20 columns that need to be split if this makes a difference.

Eddie

 

[Claus Busch]

Hi,

Am Tue, 10 Dec 2013 08:59:50 -0800 (PST) schrieb (e-mail address removed):

Thanks for this unfortunately it splits column A over 2 columns but but not original columns B and C. I showed 3 columns of data but sometimes there are up to 20 columns that need to be split if this makes a difference.

if TextToColumns doesn't work try:

Sub SplitString()
Dim LRow As Long
Dim LCol As Long
Dim i As Long
Dim Start As Integer
Dim rngC As Range

With ActiveSheet
LCol = .Cells(1, Columns.Count).End(xlToLeft).Column
For i = 2 To 2 * LCol Step 2
.Columns(i).Insert
LRow = .Cells(Rows.Count, i - 1).End(xlUp).Row
For Each rngC In .Range(.Cells(1, i - 1), .Cells(LRow, i - 1))
Start = InStrRev(rngC, " ")
rngC.Offset(, 1) = Trim(Mid(rngC, Start + 1, 99))
rngC = Trim(Left(rngC, Start - 1))
Next
Next
End With
End Sub


Regards
Claus B.

 

[eidde1]

Hi,



Am Tue, 10 Dec 2013 08:59:50 -0800 (PST) schrieb (e-mail address removed):






if TextToColumns doesn't work try:



Sub SplitString()

Dim LRow As Long

Dim LCol As Long

Dim i As Long

Dim Start As Integer

Dim rngC As Range



With ActiveSheet

LCol = .Cells(1, Columns.Count).End(xlToLeft).Column

For i = 2 To 2 * LCol Step 2

.Columns(i).Insert

LRow = .Cells(Rows.Count, i - 1).End(xlUp).Row

For Each rngC In .Range(.Cells(1, i - 1), .Cells(LRow, i - 1))

Start = InStrRev(rngC, " ")

rngC.Offset(, 1) = Trim(Mid(rngC, Start + 1, 99))

rngC = Trim(Left(rngC, Start - 1))

Next

Next

End With

End Sub





Regards

Claus B.

--

Win XP PRof SP2 / Vista Ultimate SP2

Office 2003 SP2 /2007 Ultimate SP2

Thanks so much Claus - with a few edits this piece of code has been perfect and suits my needs perfectly.
Eddie