ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

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

[复制链接]

TA的精华主题

TA的得分主题

发表于 2013-6-2 01:38 | 显示全部楼层
本帖最后由 minjiwei 于 2013-6-2 01:47 编辑

总感觉走了不少弯路,请楼主指点。另外,最后一条记录结果排序稍有不同。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. Function GetOrderNum(Str As String) As String
  9.    Dim reg As New RegExp
  10.    
  11.    With reg
  12.        .Global = True
  13.        .IgnoreCase = True
  14.        .Pattern = "[0-9/-]{9,}"
  15.    End With
  16.         
  17.    Dim mc As MatchCollection
  18.    Dim m As Match
  19.    Set mc = reg.Execute(Str)
  20.       
  21.    For Each m In mc
  22.     GetOrderNum = m.Value
  23.    Next
  24.            
  25. End Function

  26. Function t1(inputText As String) As String
  27.    
  28.    Dim Reg1 As New RegExp
  29.    
  30.    With Reg1
  31.         .Global = True
  32.         .IgnoreCase = True
  33.         .Pattern = "[0-9]{9}"
  34.    End With
  35.         
  36.    Dim OrderNum As String
  37.    OrderNum = GetOrderNum(inputText)
  38.    
  39.    Dim OutputOrder As New Dictionary
  40.          
  41.    Dim mc1 As MatchCollection
  42.    Dim m1 As Match
  43.    Set mc1 = Reg1.Execute(OrderNum)
  44.       
  45.    Dim CntOrder As Long
  46.    Dim i As Long
  47.    Dim LngLastIndex As Long
  48.    
  49.    For CntOrder = 0 To mc1.Count - 1
  50.    
  51.      If CntOrder = mc1.Count - 1 Then
  52.         LngLastIndex = Len(OrderNum)
  53.      Else
  54.         LngLastIndex = mc1.Item(CntOrder + 1).FirstIndex - 1
  55.      End If
  56.    
  57.      For i = mc1.Item(CntOrder).FirstIndex + 10 To LngLastIndex Step 3
  58.          
  59.          If Mid(OrderNum, i, 1) = "-" Then
  60.              Dim t As Long
  61.              For t = 0 To Mid(OrderNum, i + 1, 2) - Mid(OrderNum, i + 1 - 3, 2)
  62.                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
  63.              Next
  64.          ElseIf Mid(OrderNum, i, 1) = "/" Then
  65.                OutputOrder.Add Left(mc1.Item(CntOrder).Value, 7) & Mid(OrderNum, i + 1, 2), Left(mc1.Item(CntOrder).Value, 7) & Mid(OrderNum, i + 1, 2)
  66.          End If
  67.          
  68.       Next
  69.              If Not OutputOrder.Exists(mc1.Item(CntOrder).Value) Then OutputOrder.Add mc1.Item(CntOrder).Value, mc1.Item(CntOrder).Value
  70.    
  71.    Next
  72.    
  73. Dim MyArray()

  74. MyArray() = OutputOrder.Items

  75. Set OutputOrder = Nothing

  76. Dim Index As Long
  77. Dim TEMP
  78. Dim NextElement As Long

  79. NextElement = ZERO

  80. Do While (NextElement < UBound(MyArray))

  81.     Index = UBound(MyArray)

  82.     Do While (Index > NextElement)

  83.        If CLng(MyArray(Index)) < CLng(MyArray(Index - 1)) Then
  84.           TEMP = MyArray(Index)
  85.           MyArray(Index) = MyArray(Index - 1)
  86.           MyArray(Index - 1) = TEMP
  87.        End If
  88.           Index = Index - 1
  89.           gIterations = gIterations + 1
  90.     Loop

  91. NextElement = NextElement + 1
  92. gIterations = gIterations + 1

  93. Loop

  94. For i = 0 To UBound(MyArray)
  95.    t1 = Trim(t1 & " " & MyArray(i))
  96. Next
  97.    
  98. End Function

  99. Sub t()
  100. Dim i As Long
  101. Sheet1.Columns("b").ClearContents

  102. For i = 1 To Sheet1.Range("a65536").End(xlUp).Row
  103.     Sheet1.Cells(i, 2) = t1(Sheet1.Cells(i, 1))
  104. Next

  105. End Sub
复制代码



评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-6-2 23:54 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 formatD 于 2013-6-3 21:21 编辑

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

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-6-4 11:13 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
  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
复制代码

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-6-19 09:22 | 显示全部楼层
本帖最后由 delete_007 于 2013-6-25 10:14 编辑

可以定义名称就来个长的
选中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

本帖子中包含更多资源

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

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-6-21 21:10 | 显示全部楼层
*******************************************************************************
答题截止,静候总结及评分。

TA的精华主题

TA的得分主题

 楼主| 发表于 2013-6-21 21:27 | 显示全部楼层
本帖最后由 xiaofx11 于 2013-6-21 21:30 编辑





本帖子中包含更多资源

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

x

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2013-6-22 10:31 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
xiaofx11 发表于 2013-6-21 21:27

本帖子中包含更多资源

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

x

TA的精华主题

TA的得分主题

发表于 2013-6-22 13:17 | 显示全部楼层
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];")
复制代码

点评

改得好。  发表于 2013-6-23 15:49

TA的精华主题

TA的得分主题

发表于 2013-6-24 17:06 | 显示全部楼层
湊个場. FUNCTION 自订函数:

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

 

本帖子中包含更多资源

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

x

TA的精华主题

TA的得分主题

发表于 2019-9-22 11:11 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
用正则做一个自定义函数:
  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
复制代码

评分

2

查看全部评分

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

本版积分规则

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

GMT+8, 2024-3-28 23:08 , Processed in 0.050147 second(s), 8 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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