常用代码归集

jsgj2023

Sub 目录提取()
    Dim reg  As Object
    Dim m As Variant
    Dim mat As Variant
    Dim n As Integer
    Set reg = CreateObject("vbscript.regexp")
    With reg
        .Global = True
        .Pattern = "第\d+章.*?[一-龢]+.+?\d+"
        Set mat = .Execute([a1])
        For Each m In mat
            n = n + 1
            Cells(n + 1, 3) = m
        Next
    End With
End Sub

jsgj2023

Sub 给单词加分隔符_负向零宽断言()
Dim reg As Object
Dim rng As Variant
Set reg = CreateObject("vbscript.regexp")
With reg
    .Global = True
    .Pattern = "(?!^)(?=[a-z])"
    For Each rng In Range("a1:a11")
        Cells(rng.Row, 2) = .Replace(rng, "-")
    Next
End With
End Sub

jsgj2023

Sub 汇总开销记录_正向零宽断言()
Dim reg As Object
Dim n As Variant
Dim m As Variant
Set reg = CreateObject("vbscript.regexp")
With reg
    .Global = True
    .Pattern = "\d+\.?\d?(?=[元块])"
    For Each Rng In Range("b2:b6")
        For Each m In .Execute(Rng)
            n = n + m * 1
        Next
        Cells(Rng.Row, 3) = n
        n = 0
    Next
End With
End Sub

jsgj2023

Sub 正则_后向引用获取当年入职并于当年离职的员工名册()
Dim reg As Object, rng, n%
Set reg = CreateObject("vbscript.regexp")
With reg
    .Global = True
    .Pattern = "(\d{4}).+\1.+"
    For Each rng In Range("b2:b10")
        If .test(rng) Then
            n = n + 1
            Cells(n + 1, 4) = Cells(rng.Row, 1)
        End If
    Next
End With
End Sub

jsgj2023

Sub 正则_外文语句拆分为单词()
Dim reg As Object, rng, n%
Set reg = CreateObject("vbscript.regexp")
With reg
    .Global = True
    .Pattern = "[a-zA-Z]+"
    For Each rng In Range("a1:a3")
        Set mat = .Execute(rng)
        For Each m In mat
            n = n + 1
            Cells(rng.Row, n + 1) = m
        Next
        n = 0
    Next
End With
End Sub

jsgj2023

Sub 正则_将单词和注释分开_多个正则表达式循环执行()
Dim reg As Object, ar, n%, rng
Set reg = CreateObject("vbscript.regexp")
With reg
    .Global = True
    For Each ar In Array("[^a-z ]+", "[a-z ]+")
        n = n + 1
        .Pattern = ar
        For Each rng In Range("a2:a" & Cells(Rows.Count, 1).End(3).Row)
            Cells(rng.Row, n + 1) = .Replace(rng, "")
        Next
    Next
End With
End Sub

jsgj2023

Sub 数据重组()
Dim regx As Object, rng, n%, m, mat
Set regx = CreateObject("vbscript.regexp")
With regx
    .Global = True
    .Pattern = "[0-9]+.+[\.?]"
    For Each rng In Sheet3.[a1:a100]
        Set mat = .Execute(rng)
        For Each m In mat
            n = n + 2
             Cells(-1 + n, 1) = m
        Next
    Next
End With
n = 0
With regx
    .Global = True
    .Pattern = "[一-龢]+.+[。？！]"
    For Each rng In Sheet3.[a1:a100]
        Set mat = .Execute(rng)
        For Each m In mat
            n = n + 2
            Cells(n, 1) = m
        Next
    Next
End With
End Sub

jsgj2023

Sub 零宽断言_有条件添加修改记录()
Dim regx As Object, rng
Set regx = CreateObject("vbscript.regexp")
With regx
    .Global = True
    .Pattern = "(?=[川吉云粤])"
    For Each rng In [a2:a10]
      Cells(rng.Row, 2) = .Replace(rng, "(中)")
    Next
End With
End Sub

jsgj2023

Sub 正则_首尾锚定()
Dim regx As Object, n&, rng, mat, m
Set regx = CreateObject("vbscript.regexp")
With regx
    .Global = True
    .Pattern = "^[A-Z]+\d+$"
    For Each rng In [a1:a17]
        Set mat = .Execute(rng)
        For Each m In mat
        n = n + 1
        Cells(n, 2) = m
        Next
    Next
End With
End Sub

jsgj2023

Sub 多个txt文件分列导入Excel() 'by liu-aguang
    Dim sPath$, sFile$, sTxt$, i&, j&, oMH As Object
    sPath = ThisWorkbook.Path & "\"
    sFile = Dir(sPath & "*.txt")
    Do While sFile <> ""
        Open sPath & sFile For Input As #1
        sTxt = sTxt & StrConv(InputB(LOF(1), 1), vbUnicode)
        Close 1
        sFile = Dir
    Loop
    With CreateObject("vbscript.regexp")
        .Pattern = "(?:地址.([^\n\r]+)[^一-龢]+)?(?:单位.([^\n\r]+)[^一-龢]+)?收货人.([^\d\n\r]+)([\d -]*)"
        .Global = True
        Set oMH = .Execute(sTxt)
    End With
    ReDim arr(oMH.Count - 1, 3)
    For i = 0 To oMH.Count - 1
        For j = 0 To 3
            arr(i, j) = oMH(i).submatches(j)
        Next
    Next
    Range("a2").Resize(oMH.Count, 4) = arr
End Sub