关于bom中不规则的位置信息拆分

一把小刀闯天下

nzkboy 发表于 2018-9-3 15:34
我知道为什么你的代码提示错误了，是因为  L2-L6,我写成L2-6了。后来改成L2-L6后，就可以支持执行了

按8楼修改就是这个规则就是有效的，但左侧字符串左起至少要有一个字符，数字开头的作无效处理

一把小刀闯天下

nzkboy 发表于 2018-9-3 15:45
我把   If s1  s2 Then MsgBox "error:" & i:  Exit Sub
直接改为
If s1  s2 Then 改成

Option Explicit

Sub test()
  Dim arr, i, j, k, t, tt, s, s1, s2, n1, n2
  arr = [a1].CurrentRegion
  For i = 2 To UBound(arr, 1)
    s = vbNullString:
    If InStr(arr(i, 1), ",") Then
      t = Split(arr(i, 1), ",")
      For j = 0 To UBound(t)
        If InStr(t(j), "-") Then
          tt = Split(t(j), "-")
          Call spltchr(tt(0), s1, n1): Call spltchr(tt(1), s2, n2)
          If Len(s1) = 0 Then MsgBox "error!行" & i: Exit Sub
          For k = Val(n1) To Val(n2): s = s & "," & s1 & k: Next
        Else
          s = s & "," & t(j)
        End If
      Next
      arr(i, 1) = Mid(s, 2)
    ElseIf InStr(arr(i, 1), "-") Then
      t = Split(arr(i, 1), "-")
      Call spltchr(t(0), s1, n1): Call spltchr(t(1), s2, n2)
      If Len(s1) = 0 Then MsgBox "error:" & i: Exit Sub
      For j = Val(n1) To Val(n2): s = s & "," & s1 & j: Next
      arr(i, 1) = Mid(s, 2)
    End If
  Next
  [b1].Resize(UBound(arr, 1)) = arr
End Sub

Function spltchr(s, a, b)
  Dim i
  For i = 1 To Len(s)
    If IsNumeric(Mid(s, i, 1)) Then
      b = Mid(s, i): a = Replace(s, b, vbNullString)
      Exit Function
    End If
  Next
  MsgBox "error!"
End Function

nzkboy

一把小刀闯天下 发表于 2018-9-3 15:58
Option Explicit

Sub test()

哎，好久不编码，居然没看明白你的意思，这回OK了，感谢！

ykqrs

1. Sub qq()
   
2. Dim s1$, mh, i1%, i2%, x%, s$, s2$, reg, i%
   
3. Set reg = CreateObject("Vbscript.Regexp")
   
4. reg.Pattern = "([a-z A-Z _]+)(\d+)-([a-z A-Z _]+)(\d+)"
   
5. reg.Global = False
   
6. For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
   
7. s1 = Cells(i, 1).Value
   
8. Do While reg.test(s1)
   
9. Set mh = reg.Execute(s1)
   
10. s = mh(0).submatches(0)
    
11. i1 = mh(0).submatches(1)
    
12. i2 = mh(0).submatches(3)
    
13. For x = i1 To i2
    
14. s2 = s2 & s & x & "."
    
15. Next
    
16. s2 = Left(s2, Len(s2) - 1)
    
17. s1 = reg.Replace(s1, s2)
    
18. s2 = ""
    
19. Loop
    
20. Cells(i, 2) = s1
    
21. Next
    
22. End Sub

复制代码

ykqrs

用正则拆分 位置拆分.rar (16.04 KB, 下载次数: 17)

2018-9-4 15:29 上传

点击文件名下载附件

nzkboy

ykqrs 发表于 2018-9-4 15:27

朋友，你的代码有一点问题，就是L2-6这样的，不支持拆分
如果是L2-L6目前拆分是正常的。
可否稍加改进。

ykqrs

nzkboy 发表于 2018-9-5 13:42
朋友，你的代码有一点问题，就是L2-6这样的，不支持拆分
如果是L2-L6目前拆分是正常的。
可否稍加改进 ...

reg.Pattern = "([a-z A-Z _]+)(\d+)-([a-z A-Z _]+)?(\d+)"

nzkboy

ykqrs 发表于 2018-9-5 15:18
reg.Pattern = "([a-z A-Z _]+)(\d+)-([a-z A-Z _]+)?(\d+)"

只是增加了一个问号，就解决了问题，简直厉害的不要不要的！！！

nzkboy

zhjlgaojuan 发表于 2018-8-31 18:19
Sub test()
Dim SourceArr As Variant
Dim MyReg As Object, MyMatches As Object

MyReg.Pattern = "[a-z|A-Z]+(\d+)\-[a-z|A-Z]*(\d+)"
变成以下就可以支持下划线了
MyReg.Pattern = "[a-z|A-Z|_]+(\d+)\-[a-z|A-Z|_]*(\d+)"