[第94期_1]▲VBA、函数大比拼：提取订单号▲[已总结评分]

xiaofx11 · 发表于 2013-5-8 20:57

本帖最后由 delete_007 于 2013-6-25 10:23 编辑

[题目分类]题目主题
正式竞赛题

答题要求：
以CODE提交答案

提示：
无

是否参与点评与总结：
本人愿意参与点评(PS:前期评分点评，如遇解题思路超出本人能力范围，提交版主)

补充内容 (2013-5-30 11:16):
后期数据更新有误,函数题应排序

补充内容 (2013-6-21 20:09):
由于VBA题目较简单,1技术分还是很容易拿到的

xiaofx11 · 发表于 2013-5-8 21:10

Sub xiaofx11()
Dim str As String, arr, brr(), spr, sbr
Dim match, matches
Dim i As Long, j As Long, m As Integer, n As Integer
Dim str9 As String, str10 As String
j = Sheet1.Range("a65536").End(xlUp).Row
arr = WorksheetFunction.Transpose(Sheet1.Range("a1:a" & j))
ReDim brr(1 To j)
For i = 1 To j
str = arr(i)
With CreateObject("VBSCRIPT.REGEXP")
.Global = True
.Pattern = ""
.Pattern = "\d{9}([/-]\d{2,9})*"
Set matches = .Execute(str)
For Each match In matches
str9 = Left(match, 7)
str10 = Right(match, Len(match) - 7)
spr = Split(str10, "/")
For m = 0 To UBound(spr)
If IsNumeric(spr(m)) Then
If Len(brr(i)) = 0 Then
If Len(spr(m)) = 9 Then
brr(i) = spr(m)
Else
brr(i) = str9 & spr(m)
End If
Else
If Len(spr(m)) = 9 Then
brr(i) = brr(i) & " " & spr(m)
Else
brr(i) = brr(i) & " " & str9 & spr(m)
End If
End If
Else
sbr = Split(spr(m), "-")
For n = sbr(0) To sbr(1)
If Len(brr(i)) = 0 Then
brr(i) = str9 & n
Else
brr(i) = brr(i) & " " & str9 & n
End If
Next
End If
Next
Next
End With
Next
Sheet1.Range("b1").Resize(j, 1) = WorksheetFunction.Transpose(brr)
End Sub

复制代码

补充内容 (2013-6-21 19:57):
此题为群里一工作中实际用到的,当时写的答案,后期没有修改

delete_007 · 发表于 2013-5-13 19:30

本帖最后由 delete_007 于 2013-6-25 09:32 编辑

函数解：
定义名称：Y

=TRIM(MID(SUBSTITUTE('第二题(函数)'!$A1,"/",REPT(" ",200)),COLUMN('第二题(函数)'!$A:$J)*200-199,200))

复制代码

名称：Z

=LOOKUP(COLUMN('第二题(函数)'!$A:$J),IF(LEN(Y)>8,COLUMN('第二题(函数)'!$A:$J)),LEFT(Y,7))

复制代码

C1单元格公式右拉下拉：

=TEXT(SMALL(--(Z&TEXT((0&MID(Y,8^(LEN(Y)>8),2))+ROW($1:$9)-1,"[=]000;[<="&RIGHT(Y,2)&"]00;000")),COLUMN()-2),"[<1E9];")

复制代码

以A1数据为例：“755725187/89/96-97/755878720-21”
先通过“/”把数据源分隔开得到数组Y={"755725187","89","96-97","755878720-21","","","","","",""}
如果Y的长度小于9，那么表明此订单号为简写，其前7位编号应该与前一个完整订单号一致，于是通过LOOKUP来得到每个数据的前7位订单号数组
Z={"7557251","7557251","7557251","7558787","7558787","7558787","7558787","7558787","7558787","7558787"}
最后单元格的公式用来处理“-”的情况。MID提取“-”前的两个数字，然后加上0到8的数组，再使用TEXT与“-”后的两位数字比较，如果小于等于后两位数字则保持不变，否则使其变成三位数。
与订单号的前7位Z连接，然后升序排序，如果长度大于9则为无效订单号，隐藏即可。

——delete_007

leroy · 发表于 2013-5-13 21:00

本帖最后由 leroy 于 2013-5-13 21:32 编辑

限于个人水平，这里借助VBA中的普通数组和循环来解（没有对计算结果排序，不知道行不行？{:soso_e103:}），

Sub OrderNumber_Collection()
Dim i&, j&, k&, arr, result
Dim temp
With Sheets("第一题(VBA)")
arr = .Range(.[A1], .[A65536].End(3))
ReDim result(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
'第一步，解决"-"
If InStr(arr(i, 1), "-") > 0 Then
Do
j = InStr(arr(i, 1), "-")
temp = ""
If Mid(arr(i, 1), j - 2, 2) Like "##" And Mid(arr(i, 1), j + 1, 2) Like "##" Then
For k = Mid(arr(i, 1), j - 2, 2) To Mid(arr(i, 1), j + 1, 2)
temp = temp & k & "/"
Next
arr(i, 1) = Replace(Replace(arr(i, 1), Mid(arr(i, 1), j - 2, 5), temp), "//", "/")
End If
Loop While InStr(arr(i, 1), "-") > 0
End If
'第二步，解决"/"
If InStr(10, arr(i, 1), "/") > 0 Then
j = 9
Do
j = InStr(j + 1, arr(i, 1), "/")
If Mid(arr(i, 1), j + 1, 2) Like "##" And Mid(arr(i, 1), j - 9, 9) Like "#########" Then
If Mid(arr(i, 1), j + 3, 1) Like "#" = False Or Len(arr(i, 1)) = j + 2 Then
arr(i, 1) = Left(arr(i, 1), j) & Mid(arr(i, 1), j - 9, 7) & Mid(arr(i, 1), j + 1, Len(arr(i, 1)))
j = j + 7
End If
End If
Loop While InStr(j + 1, arr(i, 1), "/") > 0
End If
'第三步，提取连续的9位数字
For j = 1 To Len(arr(i, 1)) - 8
If Mid(arr(i, 1), j, 9) Like "#########" Then
If Len(result(i, 1)) = 0 Then
result(i, 1) = Mid(arr(i, 1), j, 9)
Else
result(i, 1) = result(i, 1) & " " & Mid(arr(i, 1), j, 9)
End If
End If
Next
Next
.[B:B].ClearContents
.[B1].Resize(UBound(arr)) = result
End With
End Sub

复制代码

lzyamo3057 · 发表于 2013-5-14 15:22

本帖最后由 lzyamo3057 于 2013-5-19 10:07 编辑

Sub test()
Dim RgExp, Arr, k%, brr, crr, drr(1 To 100), Err, frr(), s, i, j, m, y, x, temp
Set RgExp = CreateObject("vbScript.RegExp")
Arr = Range("A1", [A65536].End(3))
ReDim brr(1 To UBound(Arr))
For k = 1 To UBound(Arr)
With RgExp
.Global = True
.Pattern = "[\u4e00-\u9fa5 A-Za-z]|$.*?$"
brr(k) = .Replace(Arr(k, 1), "")
End With
Next
For i = LBound(brr) To UBound(brr)
m = 0
crr = Split(brr(i), "/")
s = Left(crr(0), 7)
For j = LBound(crr) To UBound(crr)
If Len(crr(j)) = 9 Then
m = m + 1
drr(m) = crr(j)
ElseIf Len(crr(j)) = 2 Then
m = m + 1
drr(m) = s & crr(j)
ElseIf InStr(crr(j), "-") Then
Err = Split(crr(j), "-")
If Len(Err(0)) >= 9 Then
s = Left(Err(0), 7)
For x = Right(Err(0), 2) To Err(1)
m = m + 1
drr(m) = s & x
Next
Else
For x = Err(0) To Err(1)
m = m + 1
drr(m) = s & x
Next
End If
End If
Next
For x = 1 To UBound(drr) - 1
For y = x + 1 To UBound(drr)
If drr(x) <> "" And drr(y) <> "" Then
If drr(x) > drr(y) Then
temp = drr(x)
drr(x) = drr(y)
drr(y) = temp
End If
End If
Next y
Next x
t = t + 1
ReDim Preserve frr(1 To t)
frr(t) = Join(drr, " ")
Erase drr
Next
[b1].Resize(UBound(frr)) = Application.WorksheetFunction.Transpose(frr)
End Sub

复制代码

smlee · 发表于 2013-5-14 16:18

本帖最后由 smlee 于 2013-5-15 14:52 编辑

Sub auto() 'smlee
Dim arr, temp
Dim i As Byte, reStr As String, j As Byte, k As Byte, temp1 As String
arr = Range("a1:a8")
For i = 1 To UBound(arr)
reStr = reStr & arr(i, 1) & Chr(10)
Next
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "$.+$"
reStr = .Replace(reStr, "")
.Pattern = "\D+[^chr(10)]\s"
reStr = .Replace(reStr, Chr(10))
End With
arr = Split(reStr, Chr(10))
For i = 1 To UBound(arr) - 1
temp = Split(arr(i), "/")
For j = 0 To UBound(temp)
If Len(temp(j)) = 2 Then
temp(j) = Mid$(temp(j - 1), 1, 7) & temp(j) & ","
ElseIf Len(temp(j)) > 9 Then
For k = Mid$(temp(j), 8, 2) To Mid$(temp(j), 11, 2)
temp1 = temp1 & Mid$(temp(j), 1, 7) & k & ","
Next
temp(j) = temp1: temp1 = ""
ElseIf Len(temp(j)) = 5 Then
For k = Mid$(temp(j), 1, 2) To Mid$(temp(j), 4, 2)
temp1 = temp1 & Mid$(temp(j - 1), 1, 7) & k & ","
Next
temp(j) = temp1: temp1 = ""
End If
Next
arr(i) = Join(temp, ",")
Next
For i = 0 To UBound(arr)
arr(i) = Replace((Replace(arr(i), ",", " ")), " ", " ")
If arr(i) <> "" Then arr(i - 1) = arr(i): arr(i) = ""
Next
[b1].Resize(UBound(arr), 1) = Application.Transpose(arr)
End Sub

复制代码

错了请给我机会改过啊。。。为了这一点技术分，俺豁出去了

Sub auto() 'smlee
Dim arr, temp1, temp2 As String
Dim reStr As String, i As Byte, j As Byte, k As Byte
arr = Range("a1:a8")
With CreateObject("VBScript.RegExp")
For i = 1 To UBound(arr)
.Pattern = "\D*$\d.*$\s|$\D\d*$"
arr(i, 1) = .Replace(arr(i, 1), "")
temp1 = Split(arr(i, 1), "/")
For j = 0 To UBound(temp1)
Select Case Len(temp1(j))
Case 2
temp1(j) = Mid$(temp1(j - 1), 1, 7) & temp1(j)
Case 5
For k = Left$(temp1(j), 2) To Right$(temp1(j), 2)
temp2 = temp2 & Mid$(temp1(j - 1), 1, 7) & k & ","
Next
temp1(j) = temp2: temp2 = ""
Case Is > 9
For k = Mid(temp1(j), InStr(1, temp1(j), "-") - 2, 2) To Right$(temp1(j), 2)
temp2 = temp2 & Mid$(temp1(j), 1, 7) & k & ","
Next
temp1(j) = temp2: temp2 = ""
End Select
Next
arr(i, 1) = Replace(Replace(Join(temp1, ","), ",", " "), " ", " ")
Next
End With
[b1].Resize(UBound(arr), 1) = arr
End Sub

复制代码

代码再优化到30行，哈哈。

sunya_0529 · 发表于 2013-5-15 15:12

本帖最后由 sunya_0529 于 2013-5-18 10:00 编辑

先贴一个VBA的，看楼主模拟的结果不像是排过序的，题目说明里也没要求，就先不管了。

Function getCode(str$) As String
Dim regExp As Object, arr1, i%, s$, arr2, j%, strTemp$
Set regExp = CreateObject("VBScript.RegExp")
With regExp
.Pattern = "\d{9}((/|-)\d+)*"
If .Test(str) Then
getCode = .Execute(str)(0)
Else
getCode = "#N/A"
End If
End With
Set regExp = Nothing
arr1 = Split(getCode, "/")
For i = 0 To UBound(arr1)
If Len(arr1(i)) > 7 Then s = Left(arr1(i), 7)
If InStr(arr1(i), "-") > 0 Then
arr2 = Split(arr1(i), "-")
For j = Val(Right(arr2(0), 2)) To Val(arr2(1))
strTemp = strTemp & " " & s & j
Next j
Else
strTemp = strTemp & " " & s & Right(arr1(i), 2)
End If
Next i
getCode = Trim(strTemp)
End Function

复制代码

AVEL · 发表于 2013-5-16 20:48

Option Explicit
Sub l()
Dim R As Object, js As Object
Dim arr As Variant, tmp As String, ff As String
Dim brr As Variant, crr As Variant
Dim i As Integer, j As Integer, k As Integer
Dim jg(), jgtmp As String
arr = Sheet1.[a1:a8]
ReDim jg(1 To UBound(arr), 1 To 1)
Set R = CreateObject("VBScript.RegExp")
With R
.Pattern = "$.+$|[A-Za-z\u4e00-\u9fa5 ]"
.Global = True
For i = 1 To UBound(arr)
tmp = .Replace(arr(i, 1), "")
If Len(tmp) > 9 Then
brr = Split(tmp, "/")
For j = 0 To UBound(brr)
If Len(brr(j)) > 7 Then ff = Left$(brr(j), 7)
If InStr(brr(j), "-") > 0 Then
crr = Split(brr(j), "-")
For k = Val(Right$(crr(0), 2)) To Val(crr(1))
jg(i, 1) = jg(i, 1) & " " & ff & k
Next
Else
jg(i, 1) = jg(i, 1) & " " & ff & Right$(brr(j), 2)
End If
Next
End If
If Len(tmp) = 9 Then jg(i, 1) = tmp
Set js = CreateObject("msscriptcontrol.scriptcontrol")
js.Language = "javascript"
jgtmp = Mid$(jg(i, 1), 2)
js.addcode "function s(x){js=x.split(' ');js.sort(function(a,b){return a-b;});return js;}"
jg(i, 1) = Replace(js.eval("s('" & jgtmp & "')"), ",", " ")
Next
End With
Set R = Nothing: Set js = Nothing
Sheet1.[b1].Resize(i - 1).Value = jg
End Sub

复制代码

VBA竞赛题很久没有过了，参与一下。

doryan · 发表于 2013-5-28 13:13

本帖最后由 doryan 于 2013-5-29 10:19 编辑

函数的估计做不来先上一个VBA的原理是:正则过滤
点评就算了函数完全菜鸟级^^
21行 VBA估计我最短了吧{:soso_e121:}

Function Regular(arg As Range) As String
Dim posStr As String, brr(100), RegX, arr, temp, i%, j%, s%
Set RegX = CreateObject("VBSCRIPT.REGEXP")
RegX.Pattern = "\d{9}[\d|\/|\-]*"
arr = Split(RegX.Execute(arg.Value).Item(0), "/")
For i = 0 To UBound(arr)
If IsNumeric(arr(i)) Then
If Len(arr(i)) = 9 Then posStr = Left(arr(i), 9 - 2)
brr(s) = posStr & Right(arr(i), 2)
s = s + 1
Else
temp = Split(arr(i), "-")
If Len(temp(0)) = 9 Then posStr = Left(temp(0), 9 - 2)
For j = Right(temp(0), 2) To Right(temp(1), 2)
brr(s) = posStr & j
s = s + 1
Next
End If
Next
Regular = Trim(Join(brr, " "))
End Function

复制代码

dengjq2000 · 发表于 2013-5-28 14:44

本帖最后由 delete_007 于 2013-6-25 09:33 编辑

C1 =IF(LEN(TRIM(MID(SUBSTITUTE(SUBSTITUTE($A1,"-","/"),"/",REPT(" ",99)),99*COLUMN(A:A)-98,99)))>2,TRIM(MID(SUBSTITUTE(SUBSTITUTE($A1,"-","/"),"/",REPT(" ",99)),99*COLUMN(A:A)-98,99)),IF(LEN(TRIM(MID(SUBSTITUTE(SUBSTITUTE($A1,"-","/"),"/",REPT(" ",99)),99*COLUMN(A:A)-98,99))),LEFT(B1,7)&TRIM(MID(SUBSTITUTE(SUBSTITUTE($A1,"-","/"),"/",REPT(" ",99)),99*COLUMN(A:A)-98,99)),""))

共计 374个字符

公式不能得到正确答案。

——delete_007

		自动登录	找回密码
密码			免费注册

[Excel 程序开发] [第94期_1]▲VBA、函数大比拼：提取订单号▲[已总结评分]

本帖子中包含更多资源

点评

评分

评分

评分

评分

评分

评分

评分

本帖子中包含更多资源

评分