Find text and move it to other cell
Hi Broogle,
How does:
"Building Maintenance Code BAS5644Na"
correspond to your data format definition:
xxxx ABC1234
!!!
Try:
'===================
Public Sub Tester001()
Dim rng As Range
Dim rCell As Range
Dim wb As Workbook
Dim SH As Worksheet
Dim SStr As String
Dim Pos As Long
Dim CalcMode As Long
Const SearchString As String = "1234"
Set wb = ActiveWorkbook '<<========== CHANGE
Set SH = wb.Sheets("Sheet2") '<<========== CHANGE
Set rng = Intersect(SH.Columns(1), SH.UsedRange)
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
For Each rCell In rng.Cells
If Not IsEmpty(rCell.Value) Then
SStr = rCell.Value
Pos = InStr(1, SStr, "Code", vbTextCompare)
SStr = Mid(SStr, Pos + 8)
SStr = Left(SStr, Len(SStr) - 5)
SStr = LTrim(SStr)
SStr = Replace(SStr, "-", "")
rCell(1, 2).Value = SStr
End If
Next rCell
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With
End Sub
'<<===================
---
Regards,
Norman
"broogle" wrote in message
ps.com...
Hi Norman,
XXXX represent text, and the sufix are between a to z or A to Z.
i.e. "Building Maintenance Code BAS5644Na" or "Silo Materials Code
SIM7721" or "Maintenance on Progress Code MAT9021a", etc.
Thanks
|