提取字符串中内容，再分离数字和汉字

Kaohsing

Sub kaohsing()
    Dim x As Object, i%, ar
    ActiveSheet.UsedRange.Offset(1, 1).ClearContents
    Set x = CreateObject("scriptcontrol"):     x.Language = "jscript"
    x.eval "function aa(aa){var tt=aa.match(/\（.*?(?=\）)/g);return tt[0].match(/\d+\D+/g);}"
    For i = 2 To [a1].End(4).Row
        If InStr(Cells(i, 1).Text, "）") Then
            ar = Split(x.Run("aa", Cells(i, 1).Text), ",")
            Cells(i, 2).Resize(1, UBound(ar) + 1) = ar
        End If
    Next
End Sub

wbhsnd

发现规律后，使用字符串查找函数也可以实现，就是麻烦一点

zopey

Sub 按钮4_Click()
    Dim arr, brr(), k0
    k0 = [a1].End(4).Row - 1
    arr = [a2].Resize(k0, 1)
    ReDim brr(1 To k0, 1 To 3)

    Dim reg, k, mh, strA$, strB$
    Set reg = CreateObject("vbscript.regexp")
    reg.Pattern = "\（(\d+\D+){0,3}\）"
    reg.Global = True

    For i = 1 To k0
        strA = arr(i, 1)
        k = 4: strB = ""
        Do
        strA = Replace(strA, strB, "")
        Set mh = reg.Execute(strA)
        If mh.Count > 0 Then
           strB = mh(0).submatches(0)
           If strB <> "" Then
              k = k - 1
              brr(i, k) = strB
           End If
        End If
        Loop Until mh.Count = 0 Or strB = ""
    Next

    [b2].Resize(k0, 3) = brr
End Sub


正则取配套.zip (9.99 KB, 下载次数: 201)

2018-7-6 17:06 上传

点击文件名下载附件

fsq119

Sub tiqu()
For j = 2 To Range("a" & 65526).End(xlUp).Row
    Set s = Range("a" & j)
    With CreateObject("vbscript.regexp")
        .Global = True
        .Pattern = "??[^??]*"
        If .test(s) Then
            s1 = .Execute(s.Value)(0)
            .Pattern = "(\d+\D+)"
            Set aaa = .Execute(s1)
            For i = 1 To aaa.Count
                s.Offset(0, i) = aaa(i - 1).submatches(0)
            Next
        End If
    End With
Next
End Sub

jd6688

如果都是符合示例中的规律，用公式可以实现。

ggmmlol

使用我做的“超级查找替换”加载宏，轻松完成数据清洗和整理：

tudarong

ggmmlol 发表于 2018-7-7 19:53
使用我做的“超级查找替换”加载宏，轻松完成数据清洗和整理：

代码可以共享学习吗？

zhangcheng6688

一把小刀闯天下 发表于 2018-7-6 06:52
'这个应该能看懂吧

Option Explicit

看不懂正则的人也就只能看看这个了，算法挺好的，谢谢

zopey

zopey 发表于 2018-7-6 17:07
Sub 按钮4_Click()
    Dim arr, brr(), k0
    k0 = [a1].End(4).Row - 1

'二次 正则匹配，无需字符串处理

Sub 按钮4_Click()
    Dim arr, brr(), k0
    k0 = [a1].End(4).Row - 1
    arr = [a2].Resize(k0, 1)
    ReDim brr(1 To k0, 1 To 9)
   
    Dim reg, reg2, k, mh, mh2
    Set reg = CreateObject("vbscript.regexp")
    reg.Pattern = "\（(.+)\）"
    reg.Global = True
   
    Set reg2 = CreateObject("vbscript.regexp")
    reg2.Pattern = "\d+\D+"
    reg2.Global = True
   
    For i = 1 To k0
       Set mh = reg.Execute(arr(i, 1))
       If mh.Count > 0 Then
         Set mh2 = reg2.Execute(mh(0).submatches(0))
         k = 0
         For j = 0 To mh2.Count - 1
             k = k + 1
             brr(i, k) = mh2(j)
         Next
       End If
     Next
     [b2].Resize(k0, 9) = brr
End Sub

zopey

reg.Pattern = "\（(.+)\）"  说明如下：

arr(1, 1)   原数据 =10*80套（2母2平）
mh(0)     有括号 =（2母2平）
mh(0).submatches(0)     不含括号 = 2母2平