Need a macro to extract certain values / characters in a cell

[Johin Chandresh.B]

Hi Guys,

I have a long sentence in one cell (A1) which contains such information

Q/O - 03T7032 QTY - 1 SYSTEM BOARD (PLANAR) ETA 16/08/2013 @ 09:00AM ORDER # - 112348135 Q/O 043N9877 QTY - 1 65W HsFGDDdEAfT SsdFGeNK FadAFfN ETA 16/08/2013 @ 09:00A M ORDER# - 178123235

I have to extract Q/O - 03T7032 ETA 16/08/2013 ORDER # - 112348135 Q/O 043N9877 ETA 16/08/2013 ORDER# - 178123235 in separate cells

There are about 2000 lines and as of now am doing it manually.

Anyone one has the knowledge of building macros, please help.

Regards,
Joe

 

[GS]

One way with benefits! It has reusable helper routines...

<In a standard module:>

Option Explicit

Type udtAppModes
Events As Boolean: CalcMode As Long: Display As Boolean: CallerID As
String
End Type
Public AppMode As udtAppModes


Sub ParseString()
Const sSource As String = "ParseString()"
Dim vData, v, v0, v1, v2, n&, j&, s1$

vData = Range(Cells(1, 1), Cells(1, 1).End(xlDown))
On Error GoTo skipit
EnableFastCode sSource
For n = LBound(vData) To UBound(vData)
v0 = Split(vData(n, 1), "QTY"): s1 = ""
For j = LBound(v0) To UBound(v0)

'Get Q/O
v1 = Split(v0(0), " ")
s1 = s1 & "~" & "Q/O " & FilterString(v1(2))
RemoveTrailingSpaces s1
v1 = Split(v0(1), "ETA"): v2 = Split(v1(1), "ORDER")

'Get ETA
s1 = s1 & "~ETA " & DateValue(FilterString(v2(0), "/ :"))
RemoveTrailingSpaces s1

'Get ORDER#
v = Split(v2(1), "Q/O")
s1 = s1 & "~ORDER# " & FilterString(v(1), , False)

skipit:
Next 'j
'Split into adjacent cells in same row
v = Split(Mid(Replace(s1, " ", " "), 2), "~")
Cells(n, 2).Resize(1, UBound(v) + 1) = v
Next 'n
Cells(1, 2).Resize(, ActiveSheet.UsedRange.Columns.Count -
1).EntireColumn.AutoFit
EnableFastCode sSource, False
End Sub

Function RemoveTrailingSpaces$(TextIn$)
Dim s1$, k%
s1 = TextIn
For k = 1 To 2
If Right(s1, 1) = " " Then s1 = Mid(s1, 1, Len(s1) - 1)
Next 'j
RemoveTrailingSpaces = Replace(s1, " ", " ")
End Function

Function FilterString$(ByVal TextIn As String, _
Optional IncludeChars As String, _
Optional IncludeLetters As Boolean = True, _
Optional IncludeNumbers As Boolean = True)
' Filters out all unwanted characters in a string.
' Arguments: TextIn The string being filtered.
' IncludeChars [Optional] Keeps any characters.
' IncludeLetters [Optional] Keeps any letters.
' IncludeNumbers [Optional] Keeps any numbers.
'
' Returns: String containing only the wanted characters.

Const sSource As String = "FilterString()"

'The basic characters to always keep
Const sLetters As String = "abcdefghijklmnopqrstuvwxyz"
Const sNumbers As String = "0123456789"

Dim i As Long, CharsToKeep As String

CharsToKeep = IncludeChars
If IncludeLetters Then _
CharsToKeep = CharsToKeep & sLetters & UCase(sLetters)
If IncludeNumbers Then CharsToKeep = CharsToKeep & sNumbers

For i = 1 To Len(TextIn)
If InStr(CharsToKeep, Mid$(TextIn, i, 1)) Then _
FilterString = FilterString & Mid$(TextIn, i, 1)
Next
End Function 'FilterString()

Sub EnableFastCode(Caller$, Optional SetFast As Boolean = True)
'The following will make sure only the Caller has control,
'and allows any Caller to take control when not in use.
If AppMode.CallerID <> Caller Then _
If AppMode.CallerID <> "" Then Exit Sub

With Application
If SetFast Then
AppMode.Display = .ScreenUpdating
.ScreenUpdating = False
AppMode.CalcMode = .Calculation
.Calculation = xlCalculationManual
AppMode.Events = .EnableEvents: .EnableEvents = False
AppMode.CallerID = Caller
Else
.ScreenUpdating = AppMode.Display
.Calculation = AppMode.CalcMode
.EnableEvents = AppMode.Events
AppMode.CallerID = ""
End If
End With
End Sub

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion

 

[Ron Rosenfeld]

Hi Guys,

I have a long sentence in one cell (A1) which contains such information

Q/O - 03T7032 QTY - 1 SYSTEM BOARD (PLANAR) ETA 16/08/2013 @ 09:00AM ORDER # - 112348135 Q/O 043N9877 QTY - 1 65W HsFGDDdEAfT SsdFGeNK FadAFfN ETA 16/08/2013 @ 09:00A M ORDER# - 178123235

I have to extract Q/O - 03T7032 ETA 16/08/2013 ORDER # - 112348135 Q/O 043N9877 ETA 16/08/2013 ORDER# - 178123235 in separate cells

There are about 2000 lines and as of now am doing it manually.

Anyone one has the knowledge of building macros, please help.

Regards,
Joe

Hmm. This seems to be the same question as you asked sixteen minutes earlier in this same news group.
Here's the same answer I posted there, with the addition of some color coding to differentiate the different groups of Q/O, ETA and Order #

In addition, I'm not sure how you want the results "split up". I chose to put pair in a separate cell, but that can be easily changed.

Here's a macro that uses regular expressions to tease things out.
I note you have some variability in how you have "Name'd" the various segments.

For example, you show Q/0 and also Q/O (zero and capital "O")
You also show ORDER and Order.

The macro accounts for that, and outputs the data as it exists in the original. However, it would be trivial to standardize it if you desired and provided appropriate rules.

The macro also assumes that your data is in column A, and the results will be written in column B and rightward; and that there is nothing of value to the right of column A

To enter this Macro (Sub), <alt-F11> opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.

To use this Macro (Sub), <alt-F8> opens the macro dialog box. Select the macro by name, and <RUN>.

===========================================
Option Explicit
Sub ExtractData()
Dim rSrc As Range, c As Range
Dim i As Long, j As Long
Dim lColor As Long
Dim re As Object, mc As Object, m As Object
Set rSrc = Range("a1", Cells(Rows.Count, "A").End(xlUp))
rSrc.Offset(columnoffset:=1).Resize(columnsize:=Columns.Count - rSrc.Column).Clear
Set re = CreateObject("vbscript.regexp")
With re
.Global = True
.ignorecase = True
.Pattern = "(Q/[0O])\W+(\w+).*?(ETA)\D+(\d+/\d+/\d+).*?(\d+)\s*:\s*(\d+).*?(ORDER)\D+(\w+)"
End With

For Each c In rSrc
If re.Test(c.Text) = True Then
j = 0
Set mc = re.Execute(c.Text)
For Each m In mc
Select Case lColor
Case Is = 0, vbYellow
lColor = vbCyan
Case Is = vbCyan
lColor = vbYellow
End Select
c.Offset(columnoffset:=j + 1).Resize(columnsize:=3).Interior.Color = lColor
'Q/O
j = j + 1
c.Offset(columnoffset:=j) = m.submatches(0) & " """ & m.submatches(1) & """"
'ETA
j = j + 1
c.Offset(columnoffset:=j) = m.submatches(2) & " """ & m.submatches(3) & " " & _
m.submatches(4) & ":" & m.submatches(5) & """"
'ORDER
j = j + 1
c.Offset(columnoffset:=j) = m.submatches(6) & " # " & m.submatches(7)
Next m
End If
Next c
End Sub
=============================================

 

[GS]

For example, you show Q/0 and also Q/O (zero and capital "O")

You also show ORDER and Order.

Good point on the case issue, though I didn't get any Q/0 in the
example strings I copy/pasted. My suggestion could be modified as
follows to address the case issue...

change this

For n = LBound(vData) To UBound(vData)
v0 = Split(vData(n, 1), "QTY"): s1 = ""

to this

For n = LBound(vData) To UBound(vData)
vData(n, 1) = UCase(vData(n, 1))
v0 = Split(vData(n, 1), "QTY"): s1 = ""

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion