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