Re: Extract text plus "n" characters or date on partial match

On Wed, 21 Mar 2007 08:46:27 -0400, Ron Rosenfeld <ronrosenfeld@xxxxxxxxxx>
wrote:

On 21 Mar 2007 05:02:45 -0700, "FabZ" <fabzeta@xxxxxxxxx> wrote:

Hi everybody,

Here there are two string samples of my cells in columnA:

der. husky b/n f 4 aa. rmd 2161 huma - p.p. adopted 10.02.04
dobermann n/f m. steril+rmd24378 faruk - p.p. trasf. palombara 13/1/05

I need to extract:

rmd 2161
rmd24378

and I started from function extracteMailAddress() found on this
newsgroup

Sub extractTattoo()

sstr = Range("A4").Text

sstr = ActiveCell.Text

p = InStr(1, sstr, "rm") - 1
Do While char <> " " And p > 0
char = Mid(sstr, p, 1)
Debug.Print "'" & char & "'"
p = p - 1
Loop

'Get tattoo address
If p > 0 Then
p = p + 1
tattoo = Mid(sstr, p, 9)
ActiveCell.Offset(0, 9).Value = tattoo

Debug.Print tatuaggio
End If
End Sub

On some cell it works, but, really, I can't say this code works and
anyway I tried also to make it work on all the column range with no
results ...

Maybe starting from the same code I need to extract dates, first,
looking for partial text match(for ex. looking for "adopted" or "-
adop." or "ado." with "*ado*") and then fill one of two cells in
different columns on the same row, always, formatting date with "dd/mm/
yyyy".

I think I need help, I'm a newbie and these codes are just a little
bit hard for my actual knowledges...
Any help would be really appreciated!
Thanks
FabZ

I don't understand your references to dates when you write that you want to
extract the "rmd" strings.

To extract the rmd strings as you write above, you could use this "regular
expression" routine:

=======================================
Option Explicit

Sub ExtractTattoo()
Dim sStr
Dim i As Long
sStr = Array("der. husky b/n f 4 aa. rmd 2161 huma - p.p. adopted 10.02.04", _
"dobermann n/f m. steril+rmd24378 faruk - p.p. trasf. palombara
13/1/05")

Dim oRegExp As Object
Dim colMatches As Object
Const sPattern As String = "rmd\s?\d+"

Set oRegExp = CreateObject("VBScript.RegExp")

With oRegExp
.IgnoreCase = True
.Global = True
.Pattern = sPattern

For i = 0 To UBound(sStr)
If oRegExp.Test(sStr(i)) = True Then
Set colMatches = oRegExp.Execute(sStr(i))
Debug.Print i, colMatches(0)
End If
Next i
End With
End Sub
=====================================
0 rmd 2161
1 rmd24378
=====================================

If you want to extract the rmd strings and the dates, you could try this
similar routine, which assumes the dates are always at the end:

=======================================

Sub ExtractTattoo()
Dim sStr
Dim i As Long
sStr = Array("der. husky b/n f 4 aa. rmd 2161 huma - p.p. adopted 10.02.04", _
"dobermann n/f m. steril+rmd24378 faruk - p.p. trasf. palombara
13/1/05")

Dim oRegExp As Object
Dim colMatches As Object
Const sPattern As String = "(rmd\s?\d+)[\s\S]+(\s\S+$)"

Set oRegExp = CreateObject("VBScript.RegExp")

With oRegExp
.IgnoreCase = True
.Global = True
.Pattern = sPattern

For i = 0 To UBound(sStr)
If oRegExp.Test(sStr(i)) = True Then
Set colMatches = oRegExp.Execute(sStr(i))
Debug.Print i, colMatches(0).submatches(0),
colMatches(0).submatches(1)
End If
Next i
End With
End Sub
============================================
0 rmd 2161 10.02.04
1 rmd24378 13/1/05
=============================================

The "work" is done by the Pattern (sPattern).

In the first case

"rmd\s?\d+"

says look for a pattern starting with
"rmd" then
an optional <space> then
all of the following digits.

In the second

"(rmd\s?\d+)[\s\S]+(\s\S+$)"

The parentheses enclose "submatches", so the first submatch will be the same
"rmd" string as before.

The code then accepts all characters and newlines (spaces and non-spaces) until
it gets to the second set of parentheses which is looking for a substring that

starts with a <space>
is followed by consecutive <non-space>'s and then by
the End of the string.
--ron

Please note there are a few lines with unwanted word-wraps. The Const line
setting up the strings for the array to test; and the debug.print line.
--ron
.

Relevant Pages

  • Re: Extract text plus "n" characters or date on partial match
    ... Here there are two string samples of my cells in columnA: ... Maybe starting from the same code I need to extract dates, first, ... extract the "rmd" strings. ... Dim i As Long ...
    (microsoft.public.excel.programming)
  • Re: Creating a Macro
    ... Dim vFindText As Variant ... Extract ?5 needs to be 5 then the symbol ... Word MVP web site http://word.mvps.org ...
    (microsoft.public.word.docmanagement)
  • Re: Extracting time from strings
    ... to hurt is in trying to determine the shift times in 24 hr format. ... Some rosters are 14 day, others are 28 although all will start on ... extract the employees name, position and section from the first columns. ... strings to extract the times. ...
    (microsoft.public.excel.programming)
  • VBA code to extract m-coefficient in linear trendlines from ALL charts
    ... online used to extract all coefficients from the trendline textbox. ... trendlines in however many charts I may have in the sheet. ... Dim sStr As String, sStr1 As String ...
    (microsoft.public.excel.misc)
  • Re: How to use binary files as resources in VB 2005
    ... my Vb 2005 project but I need to extract that to a file, ... Private Sub btnSandboxie_Click(ByVal sender As System.Object, ... Dim ResourceStream As IO.Stream ...
    (microsoft.public.dotnet.languages.vb)