不规则语句中提取，车牌号码、始点和终点

Amway@2022 · 发表于 2024-4-27 20:31

请教老师帮忙从一下不规则语句中提取，车牌号码，始点和终点

实现如上图所示！
谢谢

Amway@2022 · 发表于 2024-4-27 20:34

还有一点，将小写字母变成大写

taller · 发表于 2024-4-28 02:42

终点的规则是什么？【三山碳四报CC】为什么终点是【三山】，终点都是两个字？

chxw68 · 发表于 2024-4-28 08:06

Sub test()
Dim r%, i%
Dim arr, brr
Dim reg1 As New RegExp
Dim reg2 As New RegExp
With reg1
.IgnoreCase = True
.Global = True
.Pattern = "[\u4e00-\u9fbc][A-Z][A-Z0-9]{5}"
End With
With reg2
.Global = True
.Pattern = "([\u4e00-\u9fbc]+?)～([\u4e00-\u9fbc]+?)报[A-Z]+"
End With
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a1:a" & r)
ReDim brr(1 To 10000, 1 To 3)
m = 0
For i = 1 To UBound(arr)
If reg1.test(arr(i, 1)) Then
Set mh = reg1.Execute(arr(i, 1))
cp = UCase(mh(0))
End If
If reg2.test(arr(i, 1)) Then
m = m + 1
Set mh = reg2.Execute(arr(i, 1))
brr(m, 1) = cp
brr(m, 2) = mh(0).SubMatches(0)
brr(m, 3) = mh(0).SubMatches(1)
End If
Next
.Range("g2").Resize(m, UBound(brr, 2)) = brr
End With
End Sub

复制代码

chxw68 · 发表于 2024-4-28 08:07

练习一下正则。

limonet · 发表于 2024-4-28 10:21

关键字：￥￥￥

limonet · 发表于 2024-4-28 10:22

Sub limonet()
Dim i%, j%, k%, Arr As Variant, Brr() As Variant, Ms As Object
Arr = Application.Transpose(Intersect(Sheet1.UsedRange, Range("A:A")))
For i = 1 To UBound(Arr)
      If Len(Arr(i)) = 1 Then Arr(i) = Empty
      If Arr(i) Like "粤*[A-Z]" Then Arr(i) = Arr(i) & " "
Next i
Arr = Split(Replace(Join(Arr), "  ", "￥"), "￥")
With CreateObject("vbscript.regexp")
      .ignorecase = True: .Global = True
      For i = 0 To UBound(Arr)
         .Pattern = "粤[a-z]+\d{4,5}(?!挂)"
         j = j + 1: ReDim Preserve Brr(1 To 3, 1 To j)
         Brr(1, j) = UCase(.Execute(Arr(i))(0))
         .Pattern = "([一-龥]+)～([一-龥]{2})"
         Set Ms = .Execute(Arr(i))
         If Ms.Count - 1 Then
            Do While Ms.Count - k
                  k = k + 1
                  ReDim Preserve Brr(1 To 3, 1 To j + k - 1)
                  Brr(1, j + k - 1) = Brr(1, j): Brr(2, j + k - 1) = Ms(k - 1).submatches(0): Brr(3, j + k - 1) = Ms(k - 1).submatches(1)
            Loop
            k = 0: j = UBound(Brr, 2)
         Else
            Brr(2, j) = Ms(0).submatches(0): Brr(3, j) = Ms(0).submatches(1)
         End If
      Next i
End With
Range("F2").Resize(j, 3) = Application.Transpose(Brr)
End Sub

DevilW · 发表于 2024-4-28 11:09

DevilW · 发表于 2024-4-28 11:12

本帖最后由 DevilW 于 2024-4-28 11:23 编辑

～在下列代码中显示不正常，类似上标的一字，复制到VBA里是速显示的，不影响使用

Sub test()
Set reg = CreateObject("vbScript.Regexp")
reg.Global = True
reg.Pattern = ".*?([一-龥]\w{6}|[一-龥]+～[一-龥]+?(?=报|碳四))|.+"
ar = Range([a1], [a65535].End(3))
ReDim br(1 To UBound(ar), 1 To 3)
For i = 1 To UBound(ar)
s = Trim(reg.Replace(ar(i, 1), "$1 "))
If s <> "" Then
If Split(s)(0) = Trim(reg.Replace(s, "$1 ")) Then c = s
cr = Split(s)
For j = 0 To UBound(cr)
If InStr(cr(j), "～") Then
n = n + 1
br(n, 1) = c
br(n, 2) = Split(cr(j), "～")(0)
br(n, 3) = Split(cr(j), "～")(1)
End If
Next
End If
Next
[g2].Resize(n, 3) = br
End Sub

复制代码

grf1973 · 发表于 2024-4-28 14:03

Sub testVBA()
arr = Range("a1:a" & Cells(Rows.Count, 1).End(3).Row)
ReDim brr(1 To UBound(arr), 1 To 3)
Set reg1 = CreateObject("vbscript.regexp")
Set reg2 = CreateObject("vbscript.regexp")
reg1.Pattern = "[\u4e00-\u9fbc]\w{6}|[\u4e00-\u9fbc]\w{5}[\u4e00-\u9fbc]"
reg2.Pattern = "([\u4e00-\u9fbc]+)～([\u4e00-\u9fbc]+?)报"
For Each s In arr
If reg1.test(s) Then cph = UCase(reg1.Execute(s)(0))
If reg2.test(s) Then
n = n + 1
brr(n, 1) = cph
brr(n, 2) = reg2.Execute(s)(0).submatches(0)
brr(n, 3) = reg2.Execute(s)(0).submatches(1)
End If
Next
[g2].Resize(n, 3) = brr
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

不规则语句中提取，车牌号码、始点和终点

评分