A Microsoft Office (Excel, Word) forum. OfficeFrustration

If this is your first visit, be sure to check out the FAQ by clicking the link above. You may have to register before you can post: click the register link above to proceed. To start viewing messages, select the forum that you want to visit from the selection below.

Go Back   Home » OfficeFrustration forum » Microsoft Excel » Worksheet Functions
Site Map Home Register Authors List Search Today's Posts Mark Forums Read  

Macro to apply parsing rules for strings and list the substrings



 
 
Thread Tools Display Modes
  #11  
Old April 19th, 2009, 03:32 AM posted to microsoft.public.excel.worksheet.functions
Luciano Paulino da Silva
external usenet poster
 
Posts: 52
Default Macro to apply parsing rules for strings and list the substrings

On 18 abr, 22:12, Luciano Paulino da Silva
wrote:
On 18 abr, 15:18, Ron Rosenfeld wrote:

On Sat, 18 Apr 2009 07:50:32 -0700 (PDT), Luciano Paulino da Silva


wrote:
Dear Ron,
Excelent!!! Thank you very much!
Luciano


You're welcome. *Glad to help. *Thanks for the feedback.


Here are some links to information regarding Regular Expressions, if you need
them:


Regular Expressionshttp://www.regular-expressions.info/reference.htmlhttp://support.micr...
--ron


I`m trying but for several situations I could not implement the
rules... :-/


Dear Ron,
I had forgotten to say that in some circunstances it is necessary to
specify that the rule could avoid parse 1, 2, 3... of the letters.
For example, we have the string bellow and following a rule that parse
after K. If I specify the possibility of one (1) lost parsing, we
should have as result:

ASADASDASKASSASADASASADKASADASASAKDDAASASKASSADADA SKSASA

ASADASDASK
ASSASADASASADK
ASADASASAK
DDAASASK
ASSADADASK
SASA
ASADASDASKASSASADASASADK
ASSASADASASADKASADASASAK
ASADASASAKDDAASASK
DDAASASKASSADADASK
ASSADADASKSASA

Do you have any idea how to implement that in your script?
Thanks in advance,
Luciano
  #12  
Old April 19th, 2009, 04:03 AM posted to microsoft.public.excel.worksheet.functions
Luciano Paulino da Silva
external usenet poster
 
Posts: 52
Default Macro to apply parsing rules for strings and list the substrings

On 18 abr, 23:32, Luciano Paulino da Silva
wrote:
On 18 abr, 22:12, Luciano Paulino da Silva



wrote:
On 18 abr, 15:18, Ron Rosenfeld wrote:


On Sat, 18 Apr 2009 07:50:32 -0700 (PDT), Luciano Paulino da Silva


wrote:
Dear Ron,
Excelent!!! Thank you very much!
Luciano


You're welcome. *Glad to help. *Thanks for the feedback.


Here are some links to information regarding Regular Expressions, if you need
them:


Regular Expressionshttp://www.regular-expressions.info/reference.htmlhttp://support.micr...
--ron


I`m trying but for several situations I could not implement the
rules... :-/


Dear Ron,
I had forgotten to say that in some circunstances it is necessary to
specify that the rule could avoid parse 1, 2, 3... of the letters.
For example, we have the string bellow and following a rule that parse
after K. If I specify the possibility of one (1) lost parsing, we
should have as result:

ASADASDASKASSASADASASADKASADASASAKDDAASASKASSADADA SKSASA

ASADASDASK
ASSASADASASADK
ASADASASAK
DDAASASK
ASSADADASK
SASA
ASADASDASKASSASADASASADK
ASSASADASASADKASADASASAK
ASADASASAKDDAASASK
DDAASASKASSADADASK
ASSADADASKSASA

Do you have any idea how to implement that in your script?
Thanks in advance,
Luciano


I`m having some problems with rules 3, 9, 12, 13, 14, 15, 16, 20
  #13  
Old April 19th, 2009, 04:04 AM posted to microsoft.public.excel.worksheet.functions
Luciano Paulino da Silva
external usenet poster
 
Posts: 52
Default Macro to apply parsing rules for strings and list the substrings

On 18 abr, 22:36, Ron Rosenfeld wrote:
On Sat, 18 Apr 2009 18:12:42 -0700 (PDT), Luciano Paulino da Silva



wrote:
On 18 abr, 15:18, Ron Rosenfeld wrote:
On Sat, 18 Apr 2009 07:50:32 -0700 (PDT), Luciano Paulino da Silva


wrote:
Dear Ron,
Excelent!!! Thank you very much!
Luciano


You're welcome. *Glad to help. *Thanks for the feedback.


Here are some links to information regarding Regular Expressions, if you need
them:


Regular Expressionshttp://www.regular-expressions.info/reference.htmlhttp://support.micr...
--ron


I`m trying but for several situations I could not implement the
rules... :-/


Well, post them and I or someone will give it a try. In addition to the rules,
also post the source string and the expected results.

I don't mind doing a few.
--ron


I`m having some problems with rules 3, 9, 12, 13, 14, 15, 16, 20.
  #14  
Old April 19th, 2009, 01:14 PM posted to microsoft.public.excel.worksheet.functions
Ron Rosenfeld
external usenet poster
 
Posts: 3,719
Default Macro to apply parsing rules for strings and list the substrings

On Sat, 18 Apr 2009 20:04:16 -0700 (PDT), Luciano Paulino da Silva
wrote:

I`m having some problems with rules 3, 9, 12, 13, 14, 15, 16, 20.


You didn't give any examples of what the results would be of these rules when
applied to a target string. By that I mean to do, as you did in your initial
posting, to give an example of the input string, and what you expect as output.

That makes it more difficult to debug.

But try this:

Rule 3:

"(CKY|DKD|CKH|CKD|KKR|RRH|RRR|CRK|DRD|RRF|KRR|[^KR]|[KR]P)+[KR]?|[KR]"

Rule 9:

"D?[^KD]+K?|[KD]"

-------------------------------------

For the other rules, give some examples (and also for these rules if the
results are unexpected).

------------------------------------
--ron
  #15  
Old April 19th, 2009, 01:23 PM posted to microsoft.public.excel.worksheet.functions
Ron Rosenfeld
external usenet poster
 
Posts: 3,719
Default Macro to apply parsing rules for strings and list the substrings

On Sat, 18 Apr 2009 19:32:26 -0700 (PDT), Luciano Paulino da Silva
wrote:

Dear Ron,
I had forgotten to say that in some circunstances it is necessary to
specify that the rule could avoid parse 1, 2, 3... of the letters.
For example, we have the string bellow and following a rule that parse
after K. If I specify the possibility of one (1) lost parsing, we
should have as result:

ASADASDASKASSASADASASADKASADASASAKDDAASASKASSADAD ASKSASA

ASADASDASK
ASSASADASASADK
ASADASASAK
DDAASASK
ASSADADASK
SASA
ASADASDASKASSASADASASADK
ASSASADASASADKASADASASAK
ASADASASAKDDAASASK
DDAASASKASSADADASK
ASSADADASKSASA

Do you have any idea how to implement that in your script?
Thanks in advance,
Luciano


It would just be a matter of combining the results from the array we generate.

Examining your example result, it appears as if you want to have both the
original output with the output relevant to the number of "skipped" parsing's
below it.

Since this is getting more complex, I have taken the liberty of also outputting
the rule(s) being used; and separating the original output from the output with
the "skipped" parsing's.

This has required some modifications so I am posting the entire macro as it
presently exists.

Eventually, it might be useful to input the parameters (rule(s) and number of
skips) via a user form, instead of multiple Input Box's as I've done so far.

================================================== ====
Option Explicit
Dim aRule(0 To 1, 1 To 100) As String
Sub ParseSpecial()
Dim c As Range
Dim i As Long, j As Long
Dim vRule As Variant
Dim lSkips As Long

Dim aResRule1() As String
Dim aResRule2() As String
Dim re As Object, mc As Object, m As Object

'Rules
'construct so that all strings will have at least
'one match
'store each rule number in the corresponding element of
'the aRule array
aRule(0, 1) = "Right side of K or R; NOT if P is Right to K or R"
aRule(1, 1) = "([^KR]|[KR]P)+[KR]?|[KR]"

aRule(0, 2) = "Right side of K or R"
aRule(1, 2) = "[^KR]+[KR]?|[KR]"

aRule(0, 3) = "Right side of K or R; NOT if P is Right to K or R; " & _
"after K in CKY, DKD, CKH, CKD, KKR; after R in RRH, RRR, " & _
"CRK, DRD, RRF, KRR"
aRule(1, 3) = "(CKY|DKD|CKH|CKD|KKR|RRH|RRR|CRK|DRD|RRF|KRR|[^KR]|" & _
"[KR]P)+[KR]?|[KR]"

aRule(0, 4) = "Right side of K"
aRule(1, 4) = "[^K]+K?|K"

aRule(0, 8) = "Left side of D"
aRule(1, 8) = "D?[^D]+|D"

aRule(0, 9) = "Left side of D, Right side of K"
aRule(1, 9) = "D?[^KD]+K?|[KD]"

aRule(0, 17) = "Right side of F, L"
aRule(1, 17) = "[^FL]+[FL]?|[FL]"

vRule = _
Split(InputBox("Rule Number (for multiple rules, separate with space): "))

lSkips = InputBox(Prompt:="Number to Skip", Default:="0")

Set c = Selection 'or whatever

If c.Count 1 Then
MsgBox ("Can only select one cell")
'but could add code to iterate through a
' bunch of cells
Exit Sub
End If

'add more code to ensure validity of rule number
' --------------------------
ReDim aResRule1(0)
aResRule1(0) = c.Value
Set re = CreateObject("vbscript.regexp")
re.IgnoreCase = False
re.Global = True

For j = 0 To UBound(vRule)
re.Pattern = aRule(1, vRule(j))
ReDim aResRule2(UBound(aResRule1))
'move current results to aResRule2
For i = 0 To UBound(aResRule1)
aResRule2(i) = aResRule1(i)
Next i
'clear out aResRule1
ReDim aResRule1(0)
For i = 0 To UBound(aResRule2)
Set mc = re.Execute(aResRule2(i))
For Each m In mc
If Len(aResRule1(0)) 0 Then
ReDim Preserve aResRule1(UBound(aResRule1) + 1)
End If
aResRule1(UBound(aResRule1)) = m
Next m
Next i
Next j

'clear and write results below
WriteResults aResRule1, c.Offset(2, 0), vRule, lSkips
End Sub
'------------------------------------------------------------------------------------
Sub WriteResults(res, rDest As Range, Rules As Variant, lSkips As Long)
Dim i As Long, j As Long, k As Long
Dim res2()
'clear out range for results
Range(rDest, rDest.End(xlDown)).Clear
'write rules
With rDest.Offset(-1, 0)
.Clear
For i = 0 To UBound(Rules)
.Value = .Value & aRule(0, Rules(i)) & _
IIf(i UBound(Rules), vbLf, "")
Next i
.Font.Italic = True
.Font.Color = vbRed
i = 1
Do While InStr(i, .Value, "NOT", vbBinaryCompare) 0
With .Characters(InStr(i, .Value, "NOT", vbBinaryCompare), 3).Font
.Bold = True
.Color = vbBlack
End With
i = i + 3
Loop
End With
For i = 0 To UBound(res)
rDest(i + 1, 1).Value = res(i)
Next i

'check for skips
For j = 1 To lSkips Step lSkips 'won't execute if lSkips = 0
'move current results to res2
ReDim res2(UBound(res))
For i = 0 To UBound(res)
res2(i) = res(i)
Next i
'clear out res
ReDim res(0)
'combine
For i = 0 To UBound(res2) - lSkips
If Len(res(0)) 0 Then
ReDim Preserve res(UBound(res) + 1)
End If
For k = i To i + lSkips
res(UBound(res)) = res(UBound(res)) & _
res2(k)
Next k
Next i
Next j

If lSkips 0 Then
Set rDest = rDest.End(xlDown)(2, 1)
With rDest
.Value = "With " & lSkips & " Skip" & _
IIf(lSkips 1, "s", "") & ":"
.Font.Color = vbRed
.Font.Bold = True
For i = 0 To UBound(res)
.Offset(i + 1, 0).Value = res(i)
Next i
End With
End If

With rDest.End(xlDown)(2, 1)
.Value = "End of List of Strings"
.Font.Italic = True
.Font.Bold = True
.Font.Color = vbRed
End With
End Sub
================================================
--ron
  #16  
Old April 19th, 2009, 01:47 PM posted to microsoft.public.excel.worksheet.functions
Luciano Paulino da Silva
external usenet poster
 
Posts: 52
Default Macro to apply parsing rules for strings and list the substrings

On 19 abr, 09:14, Ron Rosenfeld wrote:
On Sat, 18 Apr 2009 20:04:16 -0700 (PDT), Luciano Paulino da Silva

wrote:
I`m having some problems with rules 3, 9, 12, 13, 14, 15, 16, 20.


You didn't give any examples of what the results would be of these rules when
applied to a target string. *By that I mean to do, as you did in your initial
posting, to give an example of the input string, and what you expect as output.

That makes it more difficult to debug.

But try this:

Rule 3:

"(CKY|DKD|CKH|CKD|KKR|RRH|RRR|CRK|DRD|RRF|KRR|[^KR]|[KR]P)+[KR]?|[KR]"

Rule 9:

"D?[^KD]+K?|[KD]"

-------------------------------------

For the other rules, give some examples (and also for these rules if the
results are unexpected).

------------------------------------
--ron


I`m sending some examples of than, sorry...
Thanks in advance,

3 Right side of K or R if P is Right to K or R; except after K
in CKY, DKD, CKH, CKD, KKR; after R in RRH, RRR, CRK, DRD, RRF, KRR

AAKASASRAAAKASASKPASASASRPSASDFCKYDSADSDKDASCKHSGA HSACKDFHASFKKRGHAHGRRHGSAHGSAHRRRFSDAGFSCRKASDRDRR FKRRS

AAK
ASASR
AAAK
ASASKPASASASRPSASDFCKYDSADSDKDASCKHSGAHSACKDFHASFK KRGHAHGRRHGSAHGSAHRRRFSDAGFSCRKASDRDRRFKRRS

9 Left side of D, Right side of K

ASASADSASASKASSASASHASASKSASASDSAAS

ASASA
DSASASK
ASSASASHASASK
SASAS
DSAAS

12 Right side of D or E except if P is Right to D or E, or if E
is Right to D or E

ASADSSASASAESASASADPASASASAEPASAASDEASASASAEESASAS

ASAD
SSASASAE
SASASADPASASASAEPASAASDEASASASAEESASAS

13 Right side of D, E and K except if P is Right to D or E, or if
E is Right to D or E

SASASDASASAESASASASKASAKPSADPASASASAEPASASASDEASAS ASEEASSAS
SASASD
ASASAE
SASASASK
ASAKPSADPASASASAEPASASASDEASASASEEASSAS

14 Right side of F, L, M, W, Y except if P is Right to F, L, M,
W, Y, if P is Left to Y

SASFASASLASASMASASWASASYASASFPASASASLPASASMPASSAWP ASASYPASASAPYASS
SASF
ASASL
ASASM
ASASW
ASASY
ASASFPASASASLPASASMPASSAWPASASYPASASAPYASS

15 Right side of F, Y, W except if P is Right to F, Y, W, if P is
Left to Y

ASSAFASASASYASASWASSASFPASASAYPASAASWPASASAPY
ASSAF
ASASASY
ASASW
ASSASFPASASAYPASAASWPASASAPY

16 Right side of K, R, F, Y, W except if P is Right to K, R, F,
Y, W, if P is Left to Y

ASSASKASASASRASASAFASSAYASASSWSASASKPASASASRPASSAF PSASASYPASASWPASSASPY
ASSASK
ASASASR
ASASAF
ASSAY
ASASSW
SASASKPASASASRPASSAFPSASASYPASASWPASSASPY

20 Left side of A, F, I, L, M, V except if D or E is Left to A,
F, I, L, M, V

TTAWFNNICCMSSVASDATTYEQTTDFQQEFQQDIQQEINNDLQWELQWQ EMQWDMWQWEVQWQWDVQWQLSTSS
TT
AW
FNN
ICC
MSS
V
ASDATTYEQTTDFQQEFQQDIQQEINNDLQWELQWQEMQWDMWQWEVQWQ WDVQWQ
LSTSS

  #17  
Old April 19th, 2009, 03:36 PM posted to microsoft.public.excel.worksheet.functions
Ron Rosenfeld
external usenet poster
 
Posts: 3,719
Default Macro to apply parsing rules for strings and list the substrings

On Sun, 19 Apr 2009 05:47:47 -0700 (PDT), Luciano Paulino da Silva
wrote:

3 Right side of K or R if P is Right to K or R; except after K
in CKY, DKD, CKH, CKD, KKR; after R in RRH, RRR, CRK, DRD, RRF, KRR

AAKASASRAAAKASASKPASASASRPSASDFCKYDSADSDKDASCKHSG AHSACKDFHASFKKRGHAHGRRHGSAHGSAHRRRFSDAGFSCRKASDRDR RFKRRS

AAK
ASASR
AAAK
ASASKPASASASRPSASDFCKYDSADSDKDASCKHSGAHSACKDFHASF KKRGHAHGRRHGSAHGSAHRRRFSDAGFSCRKASDRDRRFKRRS

9 Left side of D, Right side of K

ASASADSASASKASSASASHASASKSASASDSAAS

ASASA
DSASASK
ASSASASHASASK
SASAS
DSAAS

12 Right side of D or E except if P is Right to D or E, or if E
is Right to D or E

ASADSSASASAESASASADPASASASAEPASAASDEASASASAEESASA S

ASAD
SSASASAE
SASASADPASASASAEPASAASDEASASASAEESASAS



I think these will do: (The others will have to wait, if you can't figure it
out).

Rule3:

"(CKY|DKD|CKH|CKD|KKR|RRH|RRR|CRK|DRD|RRF|KRR|[^KR]|[KR]P)+[KR]?|[KR]"

Rule9:

"D?[^KD]+K?|[KD]"

Rule12:

"([^DE]|[DE][EP])+[DE]?|[DE]"
--ron
  #18  
Old April 19th, 2009, 04:02 PM posted to microsoft.public.excel.worksheet.functions
Luciano Paulino da Silva
external usenet poster
 
Posts: 52
Default Macro to apply parsing rules for strings and list the substrings

On 19 abr, 09:23, Ron Rosenfeld wrote:
On Sat, 18 Apr 2009 19:32:26 -0700 (PDT), Luciano Paulino da Silva



wrote:
Dear Ron,
I had forgotten to say that in some circunstances it is necessary to
specify that the rule could avoid parse 1, 2, 3... of the letters.
For example, we have the string bellow and following a rule that parse
after K. If I specify the possibility of one (1) lost parsing, we
should have as result:


ASADASDASKASSASADASASADKASADASASAKDDAASASKASSADAD ASKSASA


ASADASDASK
ASSASADASASADK
ASADASASAK
DDAASASK
ASSADADASK
SASA
ASADASDASKASSASADASASADK
ASSASADASASADKASADASASAK
ASADASASAKDDAASASK
DDAASASKASSADADASK
ASSADADASKSASA


Do you have any idea how to implement that in your script?
Thanks in advance,
Luciano


It would just be a matter of combining the results from the array we generate.

Examining your example result, it appears as if you want to have both the
original output with the output relevant to the number of "skipped" parsing's
below it.

Since this is getting more complex, I have taken the liberty of also outputting
the rule(s) being used; and separating the original output from the output with
the "skipped" parsing's.

This has required some modifications so I am posting the entire macro as it
presently exists.

Eventually, it might be useful to input the parameters (rule(s) and number of
skips) via a user form, instead of multiple Input Box's as I've done so far.

================================================== ====
Option Explicit
Dim aRule(0 To 1, 1 To 100) As String
Sub ParseSpecial()
Dim c As Range
Dim i As Long, j As Long
Dim vRule As Variant
Dim lSkips As Long

Dim aResRule1() As String
Dim aResRule2() As String
Dim re As Object, mc As Object, m As Object

'Rules
'construct so that all strings will have at least
'one match
'store each rule number in the corresponding element of
'the aRule array
aRule(0, 1) = "Right side of K or R; NOT if P is Right to K or R"
aRule(1, 1) = "([^KR]|[KR]P)+[KR]?|[KR]"

aRule(0, 2) = "Right side of K or R"
aRule(1, 2) = "[^KR]+[KR]?|[KR]"

aRule(0, 3) = "Right side of K or R; NOT if P is Right to K or R; " & _
* * "after K in CKY, DKD, CKH, CKD, KKR; after R in RRH, RRR, " & _
* * "CRK, DRD, RRF, KRR"
aRule(1, 3) = "(CKY|DKD|CKH|CKD|KKR|RRH|RRR|CRK|DRD|RRF|KRR|[^KR]|" & _
* * "[KR]P)+[KR]?|[KR]"

aRule(0, 4) = "Right side of K"
aRule(1, 4) = "[^K]+K?|K"

aRule(0, 8) = "Left side of D"
aRule(1, 8) = "D?[^D]+|D"

aRule(0, 9) = "Left side of D, Right side of K"
aRule(1, 9) = "D?[^KD]+K?|[KD]"

aRule(0, 17) = "Right side of F, L"
aRule(1, 17) = "[^FL]+[FL]?|[FL]"

vRule = _
* Split(InputBox("Rule Number (for multiple rules, separate with space): "))

lSkips = InputBox(Prompt:="Number to Skip", Default:="0")

Set c = Selection 'or whatever

If c.Count 1 Then
* * MsgBox ("Can only select one cell")
* * 'but could add code to iterate through a
* * ' *bunch of cells
* * Exit Sub
End If

'add more code to ensure validity of rule number
' --------------------------
ReDim aResRule1(0)
aResRule1(0) = c.Value
Set re = CreateObject("vbscript.regexp")
* * re.IgnoreCase = False
* * re.Global = True

For j = 0 To UBound(vRule)
* * re.Pattern = aRule(1, vRule(j))
* * ReDim aResRule2(UBound(aResRule1))
* * 'move current results to aResRule2
* * * * For i = 0 To UBound(aResRule1)
* * * * * * aResRule2(i) = aResRule1(i)
* * * * Next i
* * 'clear out aResRule1
* * ReDim aResRule1(0)
* * For i = 0 To UBound(aResRule2)
* * * * Set mc = re.Execute(aResRule2(i))
* * * * * * For Each m In mc
* * * * * * * * If Len(aResRule1(0)) 0 Then
* * * * * * * * * * ReDim Preserve aResRule1(UBound(aResRule1) + 1)
* * * * * * * * End If
* * * * * * * * * * aResRule1(UBound(aResRule1)) = m
* * * * * * Next m
* * *Next i
Next j

'clear and write results below
WriteResults aResRule1, c.Offset(2, 0), vRule, lSkips
End Sub
'------------------------------------------------------------------------------------
Sub WriteResults(res, rDest As Range, Rules As Variant, lSkips As Long)
Dim i As Long, j As Long, k As Long
Dim res2()
'clear out range for results
Range(rDest, rDest.End(xlDown)).Clear
'write rules
With rDest.Offset(-1, 0)
* * .Clear
* * For i = 0 To UBound(Rules)
* * * * .Value = .Value & aRule(0, Rules(i)) & _
* * * * * * IIf(i UBound(Rules), vbLf, "")
* * Next i
* * * * .Font.Italic = True
* * * * .Font.Color = vbRed
* * i = 1
* * Do While InStr(i, .Value, "NOT", vbBinaryCompare) 0
* * * * With .Characters(InStr(i, .Value, "NOT", vbBinaryCompare), 3).Font
* * * * * * .Bold = True
* * * * * * .Color = vbBlack
* * * * End With
* * * * i = i + 3
* * Loop
End With
* * For i = 0 To UBound(res)
* * * * rDest(i + 1, 1).Value = res(i)
* * Next i

'check for skips
For j = 1 To lSkips Step lSkips 'won't execute if lSkips = 0
* 'move current results to res2
* * * * ReDim res2(UBound(res))
* * * * For i = 0 To UBound(res)
* * * * * * res2(i) = res(i)
* * * * Next i
* * 'clear out res
* * ReDim res(0)
* * 'combine
* * For i = 0 To UBound(res2) - lSkips
* * * * If Len(res(0)) 0 Then
* * * * * * ReDim Preserve res(UBound(res) + 1)
* * * * End If
* * * * For k = i To i + lSkips
* * * * * * res(UBound(res)) = res(UBound(res)) & _
* * * * * * * * res2(k)
* * * * Next k
* * Next i
Next j

If lSkips 0 Then
* * Set rDest = rDest.End(xlDown)(2, 1)
* * With rDest
* * * * .Value = "With " & lSkips & " Skip" & _
* * * * * * IIf(lSkips 1, "s", "") & ":"
* * * * .Font.Color = vbRed
* * * * .Font.Bold = True
* * For i = 0 To UBound(res)
* * * * .Offset(i + 1, 0).Value = res(i)
* * Next i
* * End With
End If

With rDest.End(xlDown)(2, 1)
* * .Value = "End of List of Strings"
* * .Font.Italic = True
* * .Font.Bold = True
* * .Font.Color = vbRed
End With
End Sub
================================================
--ron


Dear Ron,
You are correct that it would be better to input the parameters (rule
(s) and number of
skips) via a user form, instead of multiple Box. It would be great to
select the rules and eventually skips. Could you help me with this?
Thanks in advance,
Luciano
  #19  
Old April 19th, 2009, 04:18 PM posted to microsoft.public.excel.worksheet.functions
Luciano Paulino da Silva
external usenet poster
 
Posts: 52
Default Macro to apply parsing rules for strings and list the substrings

On 19 abr, 09:23, Ron Rosenfeld wrote:
On Sat, 18 Apr 2009 19:32:26 -0700 (PDT), Luciano Paulino da Silva



wrote:
Dear Ron,
I had forgotten to say that in some circunstances it is necessary to
specify that the rule could avoid parse 1, 2, 3... of the letters.
For example, we have the string bellow and following a rule that parse
after K. If I specify the possibility of one (1) lost parsing, we
should have as result:


ASADASDASKASSASADASASADKASADASASAKDDAASASKASSADAD ASKSASA


ASADASDASK
ASSASADASASADK
ASADASASAK
DDAASASK
ASSADADASK
SASA
ASADASDASKASSASADASASADK
ASSASADASASADKASADASASAK
ASADASASAKDDAASASK
DDAASASKASSADADASK
ASSADADASKSASA


Do you have any idea how to implement that in your script?
Thanks in advance,
Luciano


It would just be a matter of combining the results from the array we generate.

Examining your example result, it appears as if you want to have both the
original output with the output relevant to the number of "skipped" parsing's
below it.

Since this is getting more complex, I have taken the liberty of also outputting
the rule(s) being used; and separating the original output from the output with
the "skipped" parsing's.

This has required some modifications so I am posting the entire macro as it
presently exists.

Eventually, it might be useful to input the parameters (rule(s) and number of
skips) via a user form, instead of multiple Input Box's as I've done so far.

================================================== ====
Option Explicit
Dim aRule(0 To 1, 1 To 100) As String
Sub ParseSpecial()
Dim c As Range
Dim i As Long, j As Long
Dim vRule As Variant
Dim lSkips As Long

Dim aResRule1() As String
Dim aResRule2() As String
Dim re As Object, mc As Object, m As Object

'Rules
'construct so that all strings will have at least
'one match
'store each rule number in the corresponding element of
'the aRule array
aRule(0, 1) = "Right side of K or R; NOT if P is Right to K or R"
aRule(1, 1) = "([^KR]|[KR]P)+[KR]?|[KR]"

aRule(0, 2) = "Right side of K or R"
aRule(1, 2) = "[^KR]+[KR]?|[KR]"

aRule(0, 3) = "Right side of K or R; NOT if P is Right to K or R; " & _
* * "after K in CKY, DKD, CKH, CKD, KKR; after R in RRH, RRR, " & _
* * "CRK, DRD, RRF, KRR"
aRule(1, 3) = "(CKY|DKD|CKH|CKD|KKR|RRH|RRR|CRK|DRD|RRF|KRR|[^KR]|" & _
* * "[KR]P)+[KR]?|[KR]"

aRule(0, 4) = "Right side of K"
aRule(1, 4) = "[^K]+K?|K"

aRule(0, 8) = "Left side of D"
aRule(1, 8) = "D?[^D]+|D"

aRule(0, 9) = "Left side of D, Right side of K"
aRule(1, 9) = "D?[^KD]+K?|[KD]"

aRule(0, 17) = "Right side of F, L"
aRule(1, 17) = "[^FL]+[FL]?|[FL]"

vRule = _
* Split(InputBox("Rule Number (for multiple rules, separate with space): "))

lSkips = InputBox(Prompt:="Number to Skip", Default:="0")

Set c = Selection 'or whatever

If c.Count 1 Then
* * MsgBox ("Can only select one cell")
* * 'but could add code to iterate through a
* * ' *bunch of cells
* * Exit Sub
End If

'add more code to ensure validity of rule number
' --------------------------
ReDim aResRule1(0)
aResRule1(0) = c.Value
Set re = CreateObject("vbscript.regexp")
* * re.IgnoreCase = False
* * re.Global = True

For j = 0 To UBound(vRule)
* * re.Pattern = aRule(1, vRule(j))
* * ReDim aResRule2(UBound(aResRule1))
* * 'move current results to aResRule2
* * * * For i = 0 To UBound(aResRule1)
* * * * * * aResRule2(i) = aResRule1(i)
* * * * Next i
* * 'clear out aResRule1
* * ReDim aResRule1(0)
* * For i = 0 To UBound(aResRule2)
* * * * Set mc = re.Execute(aResRule2(i))
* * * * * * For Each m In mc
* * * * * * * * If Len(aResRule1(0)) 0 Then
* * * * * * * * * * ReDim Preserve aResRule1(UBound(aResRule1) + 1)
* * * * * * * * End If
* * * * * * * * * * aResRule1(UBound(aResRule1)) = m
* * * * * * Next m
* * *Next i
Next j

'clear and write results below
WriteResults aResRule1, c.Offset(2, 0), vRule, lSkips
End Sub
'------------------------------------------------------------------------------------
Sub WriteResults(res, rDest As Range, Rules As Variant, lSkips As Long)
Dim i As Long, j As Long, k As Long
Dim res2()
'clear out range for results
Range(rDest, rDest.End(xlDown)).Clear
'write rules
With rDest.Offset(-1, 0)
* * .Clear
* * For i = 0 To UBound(Rules)
* * * * .Value = .Value & aRule(0, Rules(i)) & _
* * * * * * IIf(i UBound(Rules), vbLf, "")
* * Next i
* * * * .Font.Italic = True
* * * * .Font.Color = vbRed
* * i = 1
* * Do While InStr(i, .Value, "NOT", vbBinaryCompare) 0
* * * * With .Characters(InStr(i, .Value, "NOT", vbBinaryCompare), 3).Font
* * * * * * .Bold = True
* * * * * * .Color = vbBlack
* * * * End With
* * * * i = i + 3
* * Loop
End With
* * For i = 0 To UBound(res)
* * * * rDest(i + 1, 1).Value = res(i)
* * Next i

'check for skips
For j = 1 To lSkips Step lSkips 'won't execute if lSkips = 0
* 'move current results to res2
* * * * ReDim res2(UBound(res))
* * * * For i = 0 To UBound(res)
* * * * * * res2(i) = res(i)
* * * * Next i
* * 'clear out res
* * ReDim res(0)
* * 'combine
* * For i = 0 To UBound(res2) - lSkips
* * * * If Len(res(0)) 0 Then
* * * * * * ReDim Preserve res(UBound(res) + 1)
* * * * End If
* * * * For k = i To i + lSkips
* * * * * * res(UBound(res)) = res(UBound(res)) & _
* * * * * * * * res2(k)
* * * * Next k
* * Next i
Next j

If lSkips 0 Then
* * Set rDest = rDest.End(xlDown)(2, 1)
* * With rDest
* * * * .Value = "With " & lSkips & " Skip" & _
* * * * * * IIf(lSkips 1, "s", "") & ":"
* * * * .Font.Color = vbRed
* * * * .Font.Bold = True
* * For i = 0 To UBound(res)
* * * * .Offset(i + 1, 0).Value = res(i)
* * Next i
* * End With
End If

With rDest.End(xlDown)(2, 1)
* * .Value = "End of List of Strings"
* * .Font.Italic = True
* * .Font.Bold = True
* * .Font.Color = vbRed
End With
End Sub
================================================
--ron


Dear Ron,
You are correct that it would be better to input the parameters (rule
(s) and number of
skips) via a user form, instead of multiple Box. It would be great to
select the rules and eventually skips. Could you help me with this?
Thanks in advance,
Luciano
  #20  
Old April 19th, 2009, 04:24 PM posted to microsoft.public.excel.worksheet.functions
Luciano Paulino da Silva
external usenet poster
 
Posts: 52
Default Macro to apply parsing rules for strings and list the substrings

On 19 abr, 09:23, Ron Rosenfeld wrote:
On Sat, 18 Apr 2009 19:32:26 -0700 (PDT), Luciano Paulino da Silva



wrote:
Dear Ron,
I had forgotten to say that in some circunstances it is necessary to
specify that the rule could avoid parse 1, 2, 3... of the letters.
For example, we have the string bellow and following a rule that parse
after K. If I specify the possibility of one (1) lost parsing, we
should have as result:


ASADASDASKASSASADASASADKASADASASAKDDAASASKASSADAD ASKSASA


ASADASDASK
ASSASADASASADK
ASADASASAK
DDAASASK
ASSADADASK
SASA
ASADASDASKASSASADASASADK
ASSASADASASADKASADASASAK
ASADASASAKDDAASASK
DDAASASKASSADADASK
ASSADADASKSASA


Do you have any idea how to implement that in your script?
Thanks in advance,
Luciano


It would just be a matter of combining the results from the array we generate.

Examining your example result, it appears as if you want to have both the
original output with the output relevant to the number of "skipped" parsing's
below it.

Since this is getting more complex, I have taken the liberty of also outputting
the rule(s) being used; and separating the original output from the output with
the "skipped" parsing's.

This has required some modifications so I am posting the entire macro as it
presently exists.

Eventually, it might be useful to input the parameters (rule(s) and number of
skips) via a user form, instead of multiple Input Box's as I've done so far.

================================================== ====
Option Explicit
Dim aRule(0 To 1, 1 To 100) As String
Sub ParseSpecial()
Dim c As Range
Dim i As Long, j As Long
Dim vRule As Variant
Dim lSkips As Long

Dim aResRule1() As String
Dim aResRule2() As String
Dim re As Object, mc As Object, m As Object

'Rules
'construct so that all strings will have at least
'one match
'store each rule number in the corresponding element of
'the aRule array
aRule(0, 1) = "Right side of K or R; NOT if P is Right to K or R"
aRule(1, 1) = "([^KR]|[KR]P)+[KR]?|[KR]"

aRule(0, 2) = "Right side of K or R"
aRule(1, 2) = "[^KR]+[KR]?|[KR]"

aRule(0, 3) = "Right side of K or R; NOT if P is Right to K or R; " & _
* * "after K in CKY, DKD, CKH, CKD, KKR; after R in RRH, RRR, " & _
* * "CRK, DRD, RRF, KRR"
aRule(1, 3) = "(CKY|DKD|CKH|CKD|KKR|RRH|RRR|CRK|DRD|RRF|KRR|[^KR]|" & _
* * "[KR]P)+[KR]?|[KR]"

aRule(0, 4) = "Right side of K"
aRule(1, 4) = "[^K]+K?|K"

aRule(0, 8) = "Left side of D"
aRule(1, 8) = "D?[^D]+|D"

aRule(0, 9) = "Left side of D, Right side of K"
aRule(1, 9) = "D?[^KD]+K?|[KD]"

aRule(0, 17) = "Right side of F, L"
aRule(1, 17) = "[^FL]+[FL]?|[FL]"

vRule = _
* Split(InputBox("Rule Number (for multiple rules, separate with space): "))

lSkips = InputBox(Prompt:="Number to Skip", Default:="0")

Set c = Selection 'or whatever

If c.Count 1 Then
* * MsgBox ("Can only select one cell")
* * 'but could add code to iterate through a
* * ' *bunch of cells
* * Exit Sub
End If

'add more code to ensure validity of rule number
' --------------------------
ReDim aResRule1(0)
aResRule1(0) = c.Value
Set re = CreateObject("vbscript.regexp")
* * re.IgnoreCase = False
* * re.Global = True

For j = 0 To UBound(vRule)
* * re.Pattern = aRule(1, vRule(j))
* * ReDim aResRule2(UBound(aResRule1))
* * 'move current results to aResRule2
* * * * For i = 0 To UBound(aResRule1)
* * * * * * aResRule2(i) = aResRule1(i)
* * * * Next i
* * 'clear out aResRule1
* * ReDim aResRule1(0)
* * For i = 0 To UBound(aResRule2)
* * * * Set mc = re.Execute(aResRule2(i))
* * * * * * For Each m In mc
* * * * * * * * If Len(aResRule1(0)) 0 Then
* * * * * * * * * * ReDim Preserve aResRule1(UBound(aResRule1) + 1)
* * * * * * * * End If
* * * * * * * * * * aResRule1(UBound(aResRule1)) = m
* * * * * * Next m
* * *Next i
Next j

'clear and write results below
WriteResults aResRule1, c.Offset(2, 0), vRule, lSkips
End Sub
'------------------------------------------------------------------------------------
Sub WriteResults(res, rDest As Range, Rules As Variant, lSkips As Long)
Dim i As Long, j As Long, k As Long
Dim res2()
'clear out range for results
Range(rDest, rDest.End(xlDown)).Clear
'write rules
With rDest.Offset(-1, 0)
* * .Clear
* * For i = 0 To UBound(Rules)
* * * * .Value = .Value & aRule(0, Rules(i)) & _
* * * * * * IIf(i UBound(Rules), vbLf, "")
* * Next i
* * * * .Font.Italic = True
* * * * .Font.Color = vbRed
* * i = 1
* * Do While InStr(i, .Value, "NOT", vbBinaryCompare) 0
* * * * With .Characters(InStr(i, .Value, "NOT", vbBinaryCompare), 3).Font
* * * * * * .Bold = True
* * * * * * .Color = vbBlack
* * * * End With
* * * * i = i + 3
* * Loop
End With
* * For i = 0 To UBound(res)
* * * * rDest(i + 1, 1).Value = res(i)
* * Next i

'check for skips
For j = 1 To lSkips Step lSkips 'won't execute if lSkips = 0
* 'move current results to res2
* * * * ReDim res2(UBound(res))
* * * * For i = 0 To UBound(res)
* * * * * * res2(i) = res(i)
* * * * Next i
* * 'clear out res
* * ReDim res(0)
* * 'combine
* * For i = 0 To UBound(res2) - lSkips
* * * * If Len(res(0)) 0 Then
* * * * * * ReDim Preserve res(UBound(res) + 1)
* * * * End If
* * * * For k = i To i + lSkips
* * * * * * res(UBound(res)) = res(UBound(res)) & _
* * * * * * * * res2(k)
* * * * Next k
* * Next i
Next j

If lSkips 0 Then
* * Set rDest = rDest.End(xlDown)(2, 1)
* * With rDest
* * * * .Value = "With " & lSkips & " Skip" & _
* * * * * * IIf(lSkips 1, "s", "") & ":"
* * * * .Font.Color = vbRed
* * * * .Font.Bold = True
* * For i = 0 To UBound(res)
* * * * .Offset(i + 1, 0).Value = res(i)
* * Next i
* * End With
End If

With rDest.End(xlDown)(2, 1)
* * .Value = "End of List of Strings"
* * .Font.Italic = True
* * .Font.Bold = True
* * .Font.Color = vbRed
End With
End Sub
================================================
--ron


Dear Ron,
You are correct that it would be better to input the parameters (rule
(s) and number of
skips) via a user form, instead of multiple Box. It would be great to
select the rules and eventually skips. Could you help me with this?
Thanks in advance,
Luciano
 




Thread Tools
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

vB code is On
Smilies are On
[IMG] code is Off
HTML code is Off
Forum Jump


All times are GMT +1. The time now is 07:45 PM.


Powered by vBulletin® Version 3.6.4
Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 OfficeFrustration.
The comments are property of their posters.