[第127期]替换特定规则范围内的字符[已总结评分]

ggmmlol

题目内容：
1、问题描述：
A列为源字符串，其每一个字符串中，凡是有两个数字字符之间的字符都是小写字母\"e\"的，就把这两个数字之间的每一个\"e\"都替换成一个数字字符\"2\"。
2、按以上要求替换完成后，把结果填写到同一行的B列单元格中。
3、C列是对现有源数据进行手工处理完成的模拟答案，仅供验证所用，代码中不得直接“抄”用该答案。



答题要求：
1、Sheet1模块中已有CommandButton1按钮的主体代码，要求参赛者在该模块的指定的参赛者代码区域内（如下图所示）添加VBA代码，使单击该按钮运行代码后，能够完成题目内容要求的替换输出。
2、限定为仅使用VBA语言在“参赛者代码区域”内添加代码，而不得删改现有代码，不得直接或间接使用vba之外的其它编程语言；
3、参赛者添加的代码中，不允许以下情况：
    a)使用循环语句；
    b)使用其它可以起到循环执行代码功能的语句(如：递归过程、GoTo语句、GoSub语句等）；
    c)使用具有解释执行文本表达式功能的函数（如：宏表函数Evaluate）;
    d)借用工作表单元格和“名称”定义的计算功能。

评分规则：
    符合答题要求，并能得到正确结果的参赛作品，评技术分2分；对于拓展了解题思路的精彩答案，酌情再加评技术分1分。其他参与者，评财富值若干。

竞赛日期：2019-11-4至2019-12-10




来源: [EXCEL 程序开发]替换特定规则范围内的字符

liuguansky

1. Private Function ReplaceRestrictive$(ByVal StrSource$)
   
2.     Dim r As New RegExp, s$
   
3.     With r
   
4.         .Global = True
   
5.         .Pattern = "(\d+)(e+)(?=\d+)"
   
6.         If .Test(StrSource) Then
   
7.             s = "$1" & """&rept(""2"",len(""" & "$2" & """))&"""
   
8.             ReplaceRestrictive = Chr(34) & .Replace(StrSource, s) & Chr(34)
   
9.             ReplaceRestrictive = Application.Evaluate(ReplaceRestrictive)
   
10.         Else
    
11.             ReplaceRestrictive = StrSource
    
12.         End If
    
13.     End With
    
14. End Function

复制代码

前期绑定，不知道是不是违规第三点．

一把小刀闯天下

'放弃。没好好看要求是不能出现任何循环的，包括goto等。估计是要用正则来处理的

'楼主如果能删帖就把这楼删除吧，谢谢，，，

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



Option Explicit
'###############下方为参赛者代码区#####################

Private Function ReplaceRestrictive$(ByVal StrSource$)
  Dim i As Long, p As Long, flag As Boolean
  StrSource = StrSource$ & "e"
start:
  i = i + 1
  If i = Len(StrSource) Then
    ReplaceRestrictive = Left(StrSource, Len(StrSource) - 1)
    Exit Function
  End If
  If IsNumeric(Mid(StrSource, i, 1)) And Mid(StrSource, i + 1, 1) = "e" Then
    p = i + 1
    flag = True
  ElseIf flag Then
    If IsNumeric(Mid(StrSource, i + 1, 1)) And Mid(StrSource, i, 1) = "e" Then
      Mid(StrSource, p, i - p + 1) = String(i - p + 1, "2")
      flag = False
    End If
    If Mid(StrSource, i, 1) <> "e" Then flag = False
  End If
  GoTo start
End Function

ggmmlol

liuguansky 发表于 2019-11-13 12:21
前期绑定，不知道是不是违规第三点．

前期绑定并不违规。
但代码中使用了“能对文本表达式求值的函数”，不符合“答题要求”的第3条的c)项的限制，而且是该项直接以举例方式明示不得使用的"Evaluate"函数，因此，当前答案不正确。在本次竞赛题截止前，还可以继续参加，请继续努力。

另外，更新答卷请在原楼层编辑帖子，不要另占楼层。答题的方式请用附件，不要直接帖出代码。

ggmmlol

一把小刀闯天下 发表于 2019-11-13 12:38
'放弃。没好好看要求是不能出现任何循环的，包括goto等。估计是要用正则来处理的

'楼主如果能删帖就把这 ...

代码中使用了“Goto”语句，不符合答题要求，当前的附件就不下载了。
在本次竞赛截止时间之前，你还可以继续参赛。如继续参赛，请编辑原楼层的帖子，请勿另占楼层，以便于最后总结评分。

月关

'水平不到家，用循环参与一下吧

Sub test()
Dim arr, brr(), i&, x, m
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr) - 1, 1 To 1)
With CreateObject("vbscript.regexp")
.Global = True
.ignorecase = False
.Pattern = "\d(e+)(?=\d)"
For i = 2 To UBound(arr)
    brr(i - 1, 1) = arr(i, 1)
    Set x = .Execute(arr(i, 1))
        For Each m In x
            brr(i - 1, 1) = Mid(brr(i - 1, 1), 1, m.firstindex + 1) & String(m.Length - 1, "2") & Mid(brr(i - 1, 1), m.firstindex + m.Length + 1)
        Next
Next
End With
[b2].Resize(UBound(brr)) = brr
End Sub

zopey

1. Option Explicit
   
2. '###############下方为参赛者代码区#####################
   
3. 
   
4. 
   
5. Private Sub Form_Initialize()
   
6.     'MsgBox "gogo99"
   
7. End Sub
   
8.    
   
9. 
   
10. Private Function ReplaceRestrictive$(ByVal StrSource$)
    
11. Dim temp$
    
12. temp = StrSource
    
13. 
    
14. With CreateObject("VBScript.RegExp")
    
15.   .Global = True
    
16.   .IgnoreCase = False
    
17.   .Pattern = "(\d)[e]([e]*\d)"
    
18.   
    
19.    temp = .Replace(temp, "$1" & "2" & "$2")
    
20.    temp = .Replace(temp, "$1" & "2" & "$2")
    
21.    temp = .Replace(temp, "$1" & "2" & "$2")
    
22.    ReplaceRestrictive = .Replace(temp, "$1" & "2" & "$2")
    
23. End With
    
24. 
    
25. End Function
    
26. 
    
27. '###############上方为参赛者代码区#####################

复制代码

适用于 最多连续4个“e”

ggmmlol

zopey 发表于 2019-11-14 19:40
适用于 最多连续4个“e”

现有代码的第19~21行，实际是把循环执行4次的代码强行逐行写出来，同时，在这种情况下，解答仅限于连续4个"e"以内的情况，可以判定为是一种把应当以不定次的循环执行的代码改为非循环代码的失败做法。因此，当前的这个解答还不符合答题要求的第3条的规定。请继续完善答案。

月关

'左右无事温递归，为了递归而递归

Dim brr(), r As Object

Sub test2()
arr = [a1].CurrentRegion
ReDim brr(1 To UBound(arr) - 1, 1 To 1)
Set r = CreateObject("vbscript.regexp")
r.Pattern = "(.*?\d+)e(e*\d+.*)"
For i = 2 To UBound(arr)
Call dg(arr(i, 1), r, i - 1)
Next
[b2].Resize(UBound(brr)) = brr
End Sub

Function dg(s, r, n)
If r.test(s) Then s = r.Replace(s, "$12$2"): Call dg(s, r, n)
brr(n, 1) = s: Exit Function
End Function

ykqrs

赚点财富吧，不符合答题要求，直接在原代码修改的

1. Private Sub CommandButton1_Click()
   
2.     Dim r&, ar(), br(), i&, reg, m%, a
   
3.     Set reg = CreateObject("vbscript.regexp")
   
4.     r = Cells(Rows.Count, 1).End(xlUp).Row
   
5.     If r < 2 Then Exit Sub
   
6.     ar = Range("A1").Resize(r)
   
7.     ReDim br(2 To r, 1 To 1)
   
8.     reg.Pattern = "(\d)\e+(\d)"
   
9.     For i = 2 To r
   
10.     Do While reg.test(ar(i, 1))
    
11.     m = reg.Execute(ar(i, 1))(0).Length - 2
    
12.     a = Application.Rept(2, m)
    
13.     ar(i, 1) = reg.Replace(ar(i, 1), "$1" & a & "$2")
    
14.     Loop
    
15.         br(i, 1) = ar(i, 1)
    
16.     Next
    
17.     Range("b2").Resize(r - 1) = br
    
18. End Sub

复制代码