Stripping characters from strings and writing contents to another

[BatmanFromOz]

Hi

I am new to Visual Basic, but I have a worksheet with the following text in
one cell of each row. I would like to strip out the first number and place in
another cell to the right, then strip out the second number and place in it's
own cell on the right as well. Repeat the process for each row.

Wk17 to Wk21
Wk17 to Wk21
Wk17 to Wk21
Wk2 to Wk21
Wk17 to Wk21
Wk17 to Wk21

Any ideas? Thanks in advance for your help.

Adam

 

[Norman Jones]

Hi Batman.

In a stamdard module (See below),
paste the following code:

'============>>
Option Explicit

Public Sub Tester()
Dim WB As Workbook
Dim SH As Worksheet
Dim Rng As Range
Dim rCell As Range
Dim sStr As String
Dim arr As Variant

Set WB = Workbooks("Book1") '<<==== CHANGE
Set SH = WB.Sheets("Sheet1") '<<==== CHANGE

With SH
iRow = lastrow(SH, .Range("A:A"))
Set Rng = SH.Range("A1:A" & iRow)
End With

For Each rCell In Rng.Cells
With rCell
sStr = Replace(.Value, "Wk", vbNullString)
arr = Split(sStr, "to")
.Offset(0, 1).Resize(1, 2).Value = _
Array(arr(0), arr(1))
End With
Next rCell
End Sub

'--------------->
Function lastrow(SH As Worksheet, _
Optional Rng As Range)
If Rng Is Nothing Then
Set Rng = SH.Cells
End If

On Error Resume Next
lastrow = Rng.Find(What:="*", _
After:=Rng.Cells(1), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
'<<============

Alt-F11 to open the VBA Editor
Menu | Insert | Module |
Paste the above code
Alt-F11 to return to Excel
Alt-F8 to open the macro window
Select "Tester" | Run

 

[Norman Jones]

Hi Batman

I omitted to declare my iRow variable; insert:

Dim iRow As Long

After:

 

[BatmanFromOz]

Wow it works. You are fantastic and I really appreciate it.

You even provided instructions on how to launch the editor etc.

Thankyou very much!!

Adam

 

[Ron Rosenfeld]

Hi

I am new to Visual Basic, but I have a worksheet with the following text in
one cell of each row. I would like to strip out the first number and place in
another cell to the right, then strip out the second number and place in it's
own cell on the right as well. Repeat the process for each row.

Wk17 to Wk21
Wk17 to Wk21
Wk17 to Wk21
Wk2 to Wk21
Wk17 to Wk21
Wk17 to Wk21

Any ideas? Thanks in advance for your help.

Adam

If you want to leave the original unchanged, and just extract the two numbers,
you can also do it with formulas:

First number:

=LOOKUP(9.9E+307,--MID(A1,MIN(SEARCH({0,1,2,3,4,5,6,7,8,9},A1&"
0123456789")),ROW(INDIRECT("1:"&LEN(A1)))))

2nd number (first number after the <space>:

=LOOKUP(9.9E+307,--MID(A1,MIN(SEARCH({0,1,2,3,4,5,6,7,8,9},A1&"
0123456789",FIND(" ",A1))),ROW(INDIRECT("1:"&LEN(A1)))))

Another VBA method, written as a macro:

Examine the comments for certain techniques that may be of value.

There are many ways to decide if the data is valid, and/or to set up the range
on which to operate.

====================================
Option Explicit
Sub ExtrNums()
Dim c As Range, rSrc As Range
Dim re As Object, mc As Object

'Expand selection to include Current Region
' so selection could be just one cell
'Then resize to operate only on the leftmost
' column

Set rSrc = Selection.CurrentRegion
Debug.Print rSrc.Address
Set rSrc = rSrc.Resize(, 1)
Debug.Print rSrc.Address

Set re = CreateObject("vbscript.regexp")
re.Global = True
re.Pattern = "\d+"

For Each c In rSrc
'clear the two cells to the right
Range(c(1, 2), c(1, 3)).Clear

Set mc = re.Execute(c.Value)

'make sure there are two numbers in the original source
If mc.Count = 2 Then
c.Offset(0, 1).Value = CDbl(mc(0))
c.Offset(0, 2).Value = CDbl(mc(1))
End If
Next c
End Sub
==========================================
--ron