常用代码归集

jsgj2023

Sub 动态数组指定条件筛选()
Dim arr() As Variant
Dim arr1() As Variant
Dim m As Integer
Dim n As Integer
Dim rn As Variant
rn = Cells(Rows.Count, 1).End(3).Address
arr1 = Range("a2", rn)
m = Application.CountIf(Range("a2", rn), ">=80")
ReDim arr(1 To m)
For Each ar In arr1
    If ar >= 80 Then
        n = n + 1
        arr(n) = ar
    End If
    [c2].Resize(UBound(arr)) = Application.Transpose(arr)
Next
End Sub

jsgj2023

Sub 数组法去重()
Dim arr1(1 To 10) As Variant
Dim arr As Variant
Dim i As Integer
Dim j  As Integer
Dim k As Integer
Set lastcell = Cells(Rows.Count, 2).End(3)
arr = Range([b2], lastcell)
For i = 1 To lastcell.Row - 1
    For j = 1 To UBound(arr1)
        If arr(i, 1) = arr1(j) Then
            GoTo 1000
        End If
    Next j
    k = k + 1
    arr1(k) = arr(i, 1)
1000:
Next i
[e2].Resize(k) = Application.Transpose(arr1)
End Sub

jsgj2023

Sub 数组法多表合并()
Dim arr() As Variant
Dim arr1 As Variant
Dim sh As Worksheet
Dim j  As Integer
Dim n As Integer
For Each sh In Sheets
    If sh.Name <> "汇总" Then
        arr1 = sh.Range("a2:b" & sh.UsedRange.Rows.Count)
        act = act + UBound(arr1)
        ReDim Preserve arr(1 To 2, 1 To act)
        For j = 1 To UBound(arr1)
            n = n + 1
            arr(1, n) = arr1(j, 1)
            arr(2, n) = arr1(j, 2)
        Next
    End If
Next
Sheets("汇总").[a2].Resize(n, 2) = Application.Transpose(arr)
End Sub

jsgj2023

Sub 简易查询系统()
Dim arr As Variant
Dim i As Integer
Dim n As Integer
Range("i3:o999").ClearContents
arr = Range("a2", Cells(Rows.Count, 7).End(3))
For i = 1 To UBound(arr)
    If arr(i, 1) Like Range("j1").Value Then
        n = n + 1
        Cells(n + 2, 9).Resize(1, 7) = Application.Index(arr, i)
    End If
Next i
End Sub

jsgj2023

Sub 正则分组法提取身份证信息()
Dim reg As Object
Dim n  As Integer
Dim m As Variant
Set reg = CreateObject("vbscript.regexp")
n = 1
With reg
    .Global = True
    .Pattern = "(\S+) (\S+) (\S) (\d+)(( \S+){1,3})"
    Set mat = .Execute(Sheet3.Range("a1"))
    For Each m In .Execute(Sheet3.Range("a1"))
        n = n + 1
        For y = 1 To 5
            Cells(n, y) = .Replace(m, "$" & y)
        Next
    Next
End With
End Sub

jsgj2023

Sub 正则分组法提取身份证信息()
Dim reg As Object
Dim n  As Integer
Dim m As Variant
Set reg = CreateObject("vbscript.regexp")
n = 1
With reg
    .Global = True
    .Pattern = "(\S+) (\S+) (\S) (\d+)(( \S+){1,3})"
    Set mat = .Execute(Sheet3.Range("a1"))
    For Each m In mat
        n = n + 1
        For y = 1 To 5
            Cells(n, y) = .Replace(m, "$" & y)
        Next
    Next
End With
End Sub

jsgj2023

Sub 正则replace法提取()
Dim reg As Object
Dim n As Integer
Set reg = CreateObject("vbscript.regexp")
With reg
       .Global = True
    .Pattern = "([一-龢]{3,}) (\d+人)"
    Set mat = .Execute([a1])
    For Each m In mat
        n = n + 1
        Cells(n + 1, 3) = .Replace(m.Value, "$1")
        Cells(n + 1, 4) = .Replace(m.Value, "$2")
    Next
End With
End Sub

jsgj2023

Sub 正则submatches提取()
Dim reg As Object
Dim i As Integer
Set reg = CreateObject("vbscript.regexp")
With reg
       .Global = True
    .Pattern = "([一-龢]{3,}) (\d+人)"
    Set mat = .Execute([a1])
    For i = 0 To mat.Count - 1
        Cells(i + 2, 5) = mat(i).submatches(0)
        Cells(i + 2, 6) = mat(i).submatches(1)
    Next i
End With
End Sub

jsgj2023

Sub 美式排序()
    Dim arr, x%, y%, z!, d As Object, k
    Set d = CreateObject("Scripting.Dictionary")
    Range("i1").CurrentRegion.ClearContents
    arr = Range("a1").CurrentRegion
    For x = 2 To UBound(arr)
        If Not d.exists(arr(x, 2)) Then
            Set d(arr(x, 2)) = CreateObject("Scripting.Dictionary")
        End If
        d(arr(x, 2))(arr(x, 3)) = d(arr(x, 2))(arr(x, 3)) + 1
    Next
    a = d.keys: b = d.items
    For Each k In d.keys
        y = 0
        z = 1000
        Do While z >= 0
            If z <> 1000 Then
                d(k)(z * (-1)) = y + 1
                y = y + 1
                d(k).Remove z
            End If
            z = Application.Max(d(k).keys)
        Loop
    Next
    For x = 2 To UBound(arr)
        arr(x, 4) = d(arr(x, 2))(arr(x, 3) * (-1))
    Next
    Range("i1").Resize(UBound(arr), 4) = arr
End Sub

jsgj2023

Sub 正则_计算工作时间()
Dim reg As Object
Dim rn As Variant
Dim rng As Variant
Set reg = CreateObject("vbscript.regexp")
Set rng = Range("a1:a" & [a65536].End(xlUp).Row)
With reg
    .Global = True
    .Pattern = "\d+:\d+"
    For Each rn In rng
        Set mat = .Execute(rn.Value)
        Cells(rn.Row, 2) = (CDate(mat(1).Value) - CDate(mat(0).Value)) * 24
    Next
End With
End Sub