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

minjiwei

总感觉走了不少弯路，请楼主指点。另外，最后一条记录结果排序稍有不同。PS：需引用VBScript RE 和 Scripting Runtime

代码如下：

1. Option Explicit
   
2. Public Const ZERO = 0
   
3. Enum eOrderType
   
4. ASCENDING_ORDER = 0
   
5. DESCENDING_ORDER = 1
   
6. End Enum
   
7. Public gIterations
   
8. 
   
9. Function GetOrderNum(Str As String) As String
   
10.    Dim reg As New RegExp
    
11.    
    
12.    With reg
    
13.        .Global = True
    
14.        .IgnoreCase = True
    
15.        .Pattern = "[0-9/-]{9,}"
    
16.    End With
    
17.         
    
18.    Dim mc As MatchCollection
    
19.    Dim m As Match
    
20.    Set mc = reg.Execute(Str)
    
21.       
    
22.    For Each m In mc
    
23.     GetOrderNum = m.Value
    
24.    Next
    
25.            
    
26. End Function
    
27. 
    
28. Function t1(inputText As String) As String
    
29.    
    
30.    Dim Reg1 As New RegExp
    
31.    
    
32.    With Reg1
    
33.         .Global = True
    
34.         .IgnoreCase = True
    
35.         .Pattern = "[0-9]{9}"
    
36.    End With
    
37.         
    
38.    Dim OrderNum As String
    
39.    OrderNum = GetOrderNum(inputText)
    
40.    
    
41.    Dim OutputOrder As New Dictionary
    
42.          
    
43.    Dim mc1 As MatchCollection
    
44.    Dim m1 As Match
    
45.    Set mc1 = Reg1.Execute(OrderNum)
    
46.       
    
47.    Dim CntOrder As Long
    
48.    Dim i As Long
    
49.    Dim LngLastIndex As Long
    
50.    
    
51.    For CntOrder = 0 To mc1.Count - 1
    
52.    
    
53.      If CntOrder = mc1.Count - 1 Then
    
54.         LngLastIndex = Len(OrderNum)
    
55.      Else
    
56.         LngLastIndex = mc1.Item(CntOrder + 1).FirstIndex - 1
    
57.      End If
    
58.    
    
59.      For i = mc1.Item(CntOrder).FirstIndex + 10 To LngLastIndex Step 3
    
60.          
    
61.          If Mid(OrderNum, i, 1) = "-" Then
    
62.              Dim t As Long
    
63.              For t = 0 To Mid(OrderNum, i + 1, 2) - Mid(OrderNum, i + 1 - 3, 2)
    
64.                If Not OutputOrder.Exists(Left(mc1.Item(CntOrder).Value, 7) & Mid(OrderNum, i - 2, 2) + t) Then OutputOrder.Add Left(mc1.Item(CntOrder).Value, 7) & Mid(OrderNum, i - 2, 2) + t, Left(mc1.Item(CntOrder).Value, 7) & Mid(OrderNum, i - 2, 2) + t
    
65.              Next
    
66.          ElseIf Mid(OrderNum, i, 1) = "/" Then
    
67.                OutputOrder.Add Left(mc1.Item(CntOrder).Value, 7) & Mid(OrderNum, i + 1, 2), Left(mc1.Item(CntOrder).Value, 7) & Mid(OrderNum, i + 1, 2)
    
68.          End If
    
69.          
    
70.       Next
    
71.              If Not OutputOrder.Exists(mc1.Item(CntOrder).Value) Then OutputOrder.Add mc1.Item(CntOrder).Value, mc1.Item(CntOrder).Value
    
72.    
    
73.    Next
    
74.    
    
75. Dim MyArray()
    
76. 
    
77. MyArray() = OutputOrder.Items
    
78. 
    
79. Set OutputOrder = Nothing
    
80. 
    
81. Dim Index As Long
    
82. Dim TEMP
    
83. Dim NextElement As Long
    
84. 
    
85. NextElement = ZERO
    
86. 
    
87. Do While (NextElement < UBound(MyArray))
    
88. 
    
89.     Index = UBound(MyArray)
    
90. 
    
91.     Do While (Index > NextElement)
    
92. 
    
93.        If CLng(MyArray(Index)) < CLng(MyArray(Index - 1)) Then
    
94.           TEMP = MyArray(Index)
    
95.           MyArray(Index) = MyArray(Index - 1)
    
96.           MyArray(Index - 1) = TEMP
    
97.        End If
    
98.           Index = Index - 1
    
99.           gIterations = gIterations + 1
    
100.     Loop
     
101. 
     
102. NextElement = NextElement + 1
     
103. gIterations = gIterations + 1
     
104. 
     
105. Loop
     
106. 
     
107. For i = 0 To UBound(MyArray)
     
108.    t1 = Trim(t1 & " " & MyArray(i))
     
109. Next
     
110.    
     
111. End Function
     
112. 
     
113. Sub t()
     
114. Dim i As Long
     
115. Sheet1.Columns("b").ClearContents
     
116. 
     
117. For i = 1 To Sheet1.Range("a65536").End(xlUp).Row
     
118.     Sheet1.Cells(i, 2) = t1(Sheet1.Cells(i, 1))
     
119. Next
     
120. 
     
121. End Sub
     

复制代码

formatD

Attribute VB_Name = "OrderNoParser"
Dim reg As Object


Function GetOrderNo(source As String) As String
    Application.Volatile

    If reg Is Nothing Then Set reg = CreateObject("vbscript.regexp")
    reg.Global = True

    Dim mainAndSub1Length  As Integer
    Dim result As String, subCode1 As String, subCodesLeft As String
    Dim matches As MatchCollection
    Dim m As match

    reg.Pattern = "(\d{7})(\d{2}(?:-\d{2})?)(?:/(\d{2}(?:-\d{2})?))*\D"
    '概念
    '   将Code前七位成为MainCode
    '   后两位称为子Code
    '   每个可识别的代码一个MainCode加一堆以/分割的子Code构成
    '拆分的结果
    '   Item1   前7位
    '   Item2   第一个子Code 可能为 \d{2}或者\d{2}-\d{2}
    '   Item3   其他的子Code 以/分割(由于VBA的正则不支持嵌套组，所以通过将匹配结果中除去Item1和Item2的部分作为Item3)
    source = source & "/" '放在单号尾部，方便正则拆分

    Set matches = reg.Execute(source)

    If matches.Count >= 1 Then
        For i = 1 To matches.Count
            Set m = matches(i - 1)

            If m.SubMatches.Count > 1 Then
                mainCode = m.SubMatches(0)
                subCode1 = m.SubMatches(1)
                mainAndSub1Length = Len(mainCode) + Len(subCode1)

                result = Combine(result, GetFullCode(mainCode, subCode1))

                If m.SubMatches(2) <> "" Then
                    '去除首位分隔符和末尾填充字符
                    subCodesLeft = Mid(m.Value, mainAndSub1Length + 1 + 1, m.Length - mainAndSub1Length - 1 - 1)
                    result = Combine(result, GetFullCode(mainCode, subCodesLeft))
                End If
            End If
        Next i
    End If

    GetOrderNo = result

End Function

Function SplitSubCodes(codeString As String) As String()
    Dim result() As String
    Dim iCount As Integer
    Dim sourceSubCodes

    If InStr(codeString, "/") Then
        sourceSubCodes = Split(codeString, "/")
    Else
        sourceSubCodes = Array(codeString)
    End If


    iCount = 0
    ReDim Preserve result(0 To iCount)

    For i = 0 To UBound(sourceSubCodes)
        If InStr(sourceSubCodes(i), "-") Then '区间
            rangePair = Split(sourceSubCodes(i), "-")
            iStart = rangePair(0)
            iEnd = rangePair(1)

            For j = iStart To iEnd
                result(iCount) = j

                iCount = iCount + 1
                ReDim Preserve result(0 To iCount)
            Next j
        Else '简单数字
            result(iCount) = sourceSubCodes(i)

            iCount = iCount + 1
            ReDim Preserve result(0 To iCount)
        End If
    Next i

    SplitSubCodes = result
End Function


Function GetFullCode(ByVal mainCode As String, ByVal subCodeString As String) As String
    Dim result As String
    Dim subCodes

    subCodes = SplitSubCodes(subCodeString)
    For j = 0 To UBound(subCodes)
        If subCodes(j) = "" Then Exit For '待商榷

        result = Combine(result, mainCode & subCodes(j))
    Next j

    GetFullCode = result
End Function

Function Combine(string1 As String, string2 As String, Optional spliter As String = " ") As String
    If string1 = "" Then
        Combine = string2
    Else
        Combine = string1 & spliter & string2
    End If
End Function

Sub test()
    iCount = 1000
    t = Timer()
    For i = 1 To iCount
        GetOrderNo ("销DVD机芯架一批(2010.10-11) 755725187/89")
        GetOrderNo ("销针织服装一批(2010.10/12) 755484913-15/17/123456780")
        GetOrderNo ("777670939-40/42-43")
        GetOrderNo ("777670874/78-79/85/87/90(核1)")
        GetOrderNo ("777670874/887670876-78/777777777")
        GetOrderNo ("777670874/77-78/777777780-82")
        GetOrderNo ("(核)777670874")
        GetOrderNo ("777670874/887670876-78/777777777/777670939-40/42-43")
    Next i
    MsgBox "Run " & iCount & "times of 8 Lines , cost " & Timer() - t & "ms."
End Sub

小花鹿

1. Sub test()
   
2. Dim ar, i&, s, j&, k&, t1, t2, tm
   
3. ar = Sheet2.[a1].CurrentRegion
   
4. For i = 1 To UBound(ar)
   
5.     s = Replace(ar(i, 1), "(", ")")
   
6.     s = Split(s, ")")
   
7.     For j = 0 To UBound(s)
   
8.         If IsNumeric(Mid(Trim(s(j)), 1, 9)) Then
   
9.             ar(i, 1) = Trim(s(j))
   
10.         End If
    
11.     Next j
    
12. Next i
    
13. For i = 1 To UBound(ar)
    
14.     s = Split(ar(i, 1), "/")
    
15.     For j = 0 To UBound(s)
    
16.         If IsNumeric(Mid(s(j) & "|", 1, 9)) Then
    
17.             t1 = Left(s(j), 7)
    
18.         End If
    
19.         t2 = Replace(s(j), t1, "")
    
20.         t2 = Split(t2 & "-" & t2, "-")
    
21.         For k = t2(0) To t2(1)
    
22.             tm = tm & " " & t1 & k
    
23.         Next k
    
24.     Next j
    
25.     ar(i, 1) = Trim(tm)
    
26.     tm = ""
    
27. Next i
    
28. Sheet2.[b1].Resize(i - 1) = ar
    
29. End Sub
    

复制代码

5blessyou

可以定义名称就来个长的
选中C1,定义两个名称
X_1=TRIM(MID(SUBSTITUTE($A1,"/",REPT(" ",99)),99*COLUMN($A:$I)-98,99))
X_2=INDEX(X_1,N(IF({1},LEN(MMULT(9^COLUMN($A:$I)*(LEN(X_1)>5),N((ROW($1:$9)<COLUMN($B:$J))))))))
C1公式

1. =TEXT(SMALL(10^9^(RIGHT(0&X_1,2)-MID(X_1&1,8^(LEN(X_1)>8),2)<ROW($1:$9)-1)+(0&MID(X_1,8^(LEN(X_1)>8),2))+ROW($1:$9)-2+LEFT(X_2,7)/1%,COLUMN(A:A)),"[<1e9]0;")

复制代码

---

首先以“/”做分隔数据，得到数组X_1={"755725187","89","96-97","755878720-21","","","","",""}X_2的作用也是为了得到订单号的前7位编号，通过MMULT从前向后累加的方法来得到完整订单号的位置，这里的9^COLUMN($A:$I)和LEN用得很巧妙。
LEFT(X_2,7)={"7557251","7557251","7557251","7558787","7558787","7558787","7558787","7558787","7558787"}
单元格公式：用“-”后的两位数字减去“-”前的两位数字，RIGHT(0&X_1,2)-MID(X_1&1,8^(LEN(X_1)>8),2)={0,0,1,1,-1,-1,-1,-1,-1}
再与{0;1;2;3;4;5;6;7;8}比较，如果满足条件，就会得到10^9（大数，屏蔽），否则为1.
加上订单号的后两位(0&MID(X_1,8^(LEN(X_1)>8),2))+ROW($1:$9)-2
以及订单号的前7位LEFT(X_2,7)/1%
最后TEXT+SMALL得出结果。


——delete_007

delete_007

*******************************************************************************
答题截止，静候总结及评分。

xiaofx11

小花鹿

xiaofx11 发表于 2013-6-21 21:27

5blessyou

delete_007 发表于 2013-5-13 19:30
函数解：
定义名称：Y名称：ZC1单元格公式右拉下拉：

公式是不是第一个text第二段00貌似不能省略吧！01-03比如
我写的太复杂，在你的定义YZ两个名词的基础上，C1公式可以优化为

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

复制代码

准提部林

湊个場． FUNCTION 自订函数：

1. 
   
2. Function SPString(uStr$, uMark$) As String
   
3. Dim CC, TT, xT$, j&, Jm%, T1, T2, uGG$, TXT$
   
4. For j = 1 To Len(uStr) + 1
   
5.     If T1 = 0 And Mid(uStr, j, 9) Like "#########" Then T1 = j
   
6.     If T1 > 0 And InStr("0123456789/-", Mid(uStr & "P", j, 1)) = 0 Then T2 = j: Exit For
   
7. Next
   
8. If T1 > 0 And T2 > 0 Then TXT = Mid(uStr, T1, T2 - T1) Else Exit Function
   
9. For Each TT In Split(TXT, "/")
   
10.     CC = Split(TT & "-00", "-"):  T1 = CC(0):  T2 = CC(1)
    
11.     TT = Left(IIf(T1 Like "#########", T1, xT), 7)
    
12.     T1 = TT & Right(T1, 2):  T2 = TT & Right(T2, 2)
    
13.     If T2 < T1 Then T2 = T1
    
14.     For j = T1 To T2
    
15.         xT = Format(j, "000000000"):   uGG = uGG & uMark & xT
    
16.     Next
    
17. Next
    
18. SPString = Mid(uGG, Len(uMark) + 1)
    
19. End Function
    

复制代码

　

　

ggmmlol

用正则做一个自定义函数：

1. Function OrderNumber$(ByVal bookRcd$)
   
2.     Dim reg, a$, b, c
   
3.     Set reg = CreateObject("vbscript.regexp")
   
4.     reg.Pattern = "(?:\D|^)(\d{7})(\d\d([-/]\d\d)*)(?!\d)"
   
5.     reg.Global = True
   
6.     For Each ma In reg.Execute(bookRcd)
   
7.         a = ma.submatches(0)
   
8.         For Each b In Split(ma.submatches(1), "/")
   
9.             c = Split(b & "-" & b, "-")
   
10.             If Val(c(1)) < Val(c(0)) Then s = -1 Else s = 1
    
11.             For j = Val(c(0)) To Val(c(1)) Step s
    
12.                 OrderNumber = OrderNumber & " " & a & Format(j, "00")
    
13.             Next
    
14.         Next
    
15.     Next
    
16.     OrderNumber = Mid(OrderNumber, 2)
    
17. End Function

复制代码