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

nzkboy

bom在整理过程中，有一些不标准的，希望整理成标准模式
如C1-C5,应该整理成C1,C2,C3,C4,C5
详细见附件。


位置拆分.zip (6.58 KB, 下载次数: 39)

2018-8-31 17:38 上传

点击文件名下载附件
位置拆分

小花鹿

你这问题只有你自己明白，谁也不懂C10-C101，怎么来的C10,C11,C12                                      

zhjlgaojuan

Sub test()
Dim SourceArr As Variant
Dim MyReg As Object, MyMatches As Object
Dim St&, Co&, strTmp1$, strTmp2$
Set MyReg = CreateObject("vbscript.regexp")
MyReg.Pattern = "[a-z|A-Z]+(\d+)\-[a-z|A-Z]*(\d+)"
MyReg.Global = True
SourceArr = Range("a2:a" & UsedRange.Rows.Count)
For i = 1 To UBound(SourceArr)
    If MyReg.test(SourceArr(i, 1)) Then
        Set MyMatches = MyReg.Execute(SourceArr(i, 1))
        For Each tmpmatch In MyMatches
            St = tmpmatch.submatches(0)
            Co = tmpmatch.submatches(1)
            strTmp1 = Replace(Left(tmpmatch, InStr(tmpmatch, "-") - 1), tmpmatch.submatches(0), "")
            strTmp2 = ""
            For j = St To Co
               strTmp2 = strTmp2 & strTmp1 & j & ","
            Next
            strTmp2 = Left(strTmp2, Len(strTmp2) - 1)
            SourceArr(i, 1) = Replace(SourceArr(i, 1), tmpmatch, strTmp2)
        Next
    End If
Next
[c2].Resize(UBound(SourceArr), 1) = SourceArr
End Sub

一把小刀闯天下

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 s1 <> s2 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 s1 <> s2 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

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

SourceArr = Range("a2:a" & UsedRange.Rows.Count)  这一句居然报错，运行时错误424，要求对象
不过我直接强制A2:A6,测试拆分数据完美

nzkboy

一把小刀闯天下 发表于 2018-8-31 18:38
Option Explicit

Sub test()

"error!行"  执行到A4的时候就报错退出来了。不知道这一个强制退出的理由是什么？不理解，请解释一下吧，谢谢！

nzkboy

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

TDD_1-TDD_8
这样的可否拆分呢，有下划线，可以认为是字母考虑
当前的代码没有针对以上内容做动作。

一把小刀闯天下

nzkboy 发表于 2018-9-3 11:44
"error!行"  执行到A4的时候就报错退出来了。不知道这一个强制退出的理由是什么？不理解，请解释一下吧， ...

规则问题，你如果觉得这行的规则是合理的，那就修改一下条件（共2处）
If s1 <> s2 Then 改成

If Len(s1) = 0 Then

nzkboy

一把小刀闯天下 发表于 2018-9-3 14:34
规则问题，你如果觉得这行的规则是合理的，那就修改一下条件（共2处）
If s1  s2 Then 改成

我知道为什么你的代码提示错误了，是因为  L2-L6,我写成L2-6了。后来改成L2-L6后，就可以支持执行了

nzkboy

一把小刀闯天下 发表于 2018-9-3 14:34
规则问题，你如果觉得这行的规则是合理的，那就修改一下条件（共2处）
If s1  s2 Then 改成

我把   If s1 <> s2 Then MsgBox "error:" & i:  Exit Sub
直接改为
If s1 <> s2 Then 改成

If Len(s1) = 0 Then

提示next没有for

还请赐教