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. |
|
|
Thread Tools | Display Modes |
#11
|
|||
|
|||
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
|
|||
|
|||
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
|
|||
|
|||
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
|
|||
|
|||
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
|
|||
|
|||
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
|
|||
|
|||
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
|
|||
|
|||
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
|
|||
|
|||
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
|
|||
|
|||
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
|
|||
|
|||
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 | |
|
|