ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 9461|回复: 44

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-11-4 16:23 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 delete_007 于 2019-12-14 10:36 编辑

题目内容:
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 程序开发]替换特定规则范围内的字符

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

评分

7

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-11-13 12:21 | 显示全部楼层
本帖最后由 liuguansky 于 2019-11-13 12:24 编辑
  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
复制代码
前期绑定,不知道是不是违规第三点.

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-11-13 12:38 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 一把小刀闯天下 于 2019-11-13 12:49 编辑

'放弃。没好好看要求是不能出现任何循环的,包括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

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

评分

3

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-11-13 13:34 | 显示全部楼层
liuguansky 发表于 2019-11-13 12:21
前期绑定,不知道是不是违规第三点.

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

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

点评

竞赛期间以短消息的方式沟通,别人是看不到你的回帖的。  发表于 2019-12-14 10:28

TA的精华主题

TA的得分主题

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

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

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

TA的精华主题

TA的得分主题

发表于 2019-11-14 16:29 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 月关 于 2019-11-17 09:13 编辑

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

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

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-11-14 19:40 | 显示全部楼层
  1. Option Explicit
  2. '###############下方为参赛者代码区#####################


  3. Private Sub Form_Initialize()
  4.     'MsgBox "gogo99"
  5. End Sub
  6.    

  7. Private Function ReplaceRestrictive$(ByVal StrSource$)
  8. Dim temp$
  9. temp = StrSource

  10. With CreateObject("VBScript.RegExp")
  11.   .Global = True
  12.   .IgnoreCase = False
  13.   .Pattern = "(\d)[e]([e]*\d)"
  14.   
  15.    temp = .Replace(temp, "$1" & "2" & "$2")
  16.    temp = .Replace(temp, "$1" & "2" & "$2")
  17.    temp = .Replace(temp, "$1" & "2" & "$2")
  18.    ReplaceRestrictive = .Replace(temp, "$1" & "2" & "$2")
  19. End With

  20. End Function

  21. '###############上方为参赛者代码区#####################
复制代码
适用于 最多连续4个“e”

评分

2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-11-14 21:25 | 显示全部楼层
zopey 发表于 2019-11-14 19:40
适用于 最多连续4个“e”

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

TA的精华主题

TA的得分主题

发表于 2019-11-16 13:05 | 显示全部楼层
本帖最后由 月关 于 2019-11-17 09:14 编辑

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

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

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-11-18 15:40 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
赚点财富吧,不符合答题要求,直接在原代码修改的
  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
复制代码

评分

1

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-7-13 20:22 , Processed in 0.050184 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表