常用代码归集

jsgj2023

Sub 随机乱序排序()
    Dim rng As Range
    Dim r As Long
    Dim c As Long
    Randomize
    Application.ScreenUpdating = False
        With ActiveSheet
            r = .Range("a1").CurrentRegion.Rows.Count
            c = .Range("a2").CurrentRegion.Columns.Count
            For i = 3 To r - 1
                .Cells(i, c + 1) = Int((Rnd * 100) + 1)
            Next
            Set rng = .Range(Cells(3, 1), Cells(r - 1, c + 1))
            rng.Sort key1:=.Range(Cells(3, c + 1), Cells(r - 1, c + 1))
            .Columns(c + 1).Clear
        End With
    Application.ScreenUpdating = True
End Sub

jsgj2023

Sub 模糊查询()
Dim result As String
Dim str1 As String
Dim c As Range
Dim rng As Range
result = Application.InputBox(prompt:="请输入要查找的值:", Title:="模糊查找", Type:=2)
If result = "False" Or result = "" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set rng = ActiveSheet.Range("a1").CurrentRegion
str1 = "*" & result & "*"
For Each c In rng.Cells
    If c.Value Like str1 Then
        c.Interior.ColorIndex = 4
    End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

jsgj2023

Sub 生成随机数并筛选非重复值()
    Dim x As Integer
    Dim i  As Long
    Dim rng As Range
    Application.ScreenUpdating = False
    Randomize
    With ActiveSheet
        For x = 2 To 1001
            .Cells(x, 1) = Int(Rnd * 1000 + 1)
        Next x
        i = .Range("a1").End(xlDown).Row
        If i > 1001 Then Exit Sub
        Set rng = .Range(Cells(2, 1), Cells(i, 1))
        .Columns("b").ClearContents
        rng.AdvancedFilter Action:=xlFilterCopy, copytorange:=.Range("b2"), unique:=True
    End With
    Application.ScreenUpdating = True
End Sub

jsgj2023

'根据简码输入全码
Private Sub Worksheet_Change(ByVal T As Range)
    Dim s As Variant
    Dim rng As Range
    Dim i As Long
    Dim c As Range
    If T.Column = 3 And T.Row > 2 And T.Value <> "" Then
        s = T.Value
        With Sheets("编码")
            i = .Range("a1").End(4).Row
            Set rng = .Range(.Cells(2, 1), .Cells(i, 1))
            Set c = rng.Find(what:=s)
            If c Is Nothing Then Exit Sub
            T.Value = c.Offset(, 1).Value
        End With
    End If
End Sub

jsgj2023

Sub 查找上一个()
    Dim c As Range
    Dim result As String
    Dim str1 As String
    Dim str2 As String
    If c Is Nothing Then
        result = Application.InputBox(prompt:="请输入要查找的值:", Title:="查找", Type:=2)
        If result = "False" Or result = "" Then Exit Sub
        Set c = ActiveSheet.Cells.Find(result, , , xlWhole, xlByColumns, xlPrevious, False)
    Else
        Set c = ActiveSheet.Cells.FindPrevious(c)
    End If
    If Not c Is Nothing Then
        c.Activate
    End If
End Sub

jsgj2023

Sub 查找指定格式的单元格()
With Application.FindFormat.Font
    .Name = "宋体"
    .FontStyle = "Bold"
    .Size = 11
End With
Cells.Find(what:="", searchformat:=True).Activate
Selection.Interior.ColorIndex = 5
End Sub

jsgj2023

Sub 锁定及隐藏公式()
    If ActiveSheet.ProtectContents = True Then
        MsgBox "工作表已保护!"
    End If
    Worksheets("Sheet1").Range("a1").CurrentRegion.Select
    Selection.Locked = False
    Selection.FormulaHidden = False
    Selection.SpecialCells(xlCellTypeFormulas).Select
    Selection.Locked = True
    Selection.FormulaHidden = True
    Worksheets("Sheet1").Protect DrawingObjects:=True, contents:=True, scenaruos:=True
    Worksheets("Sheet1").EnableSelection = xlNoRestrictions
End Sub

jsgj2023

Sub 自动填充公式()
Dim i As Long
Dim j As Long
With Range("a1").CurrentRegion
    i = .Rows.Count - 1
    j = .Columns.Count - 1
End With
Range("j3").AutoFill Destination:=Range(Cells(3, 10), Cells(i, 10))
Range("d16").AutoFill Destination:=Range(Cells(16, 4), Cells(16, j))
End Sub

jsgj2023

Sub 判断单元格是否包含公式()
Dim rng As Range
Set rng = ActiveSheet.Range("a1").CurrentRegion
For Each c In rng.Cells
    If c.HasFormula Then
        MsgBox "单元格" & c.Address & "定义了公式!"
    End If
Next c
End Sub

jsgj2023

Sub 从身份证号码中提取性别()
    Dim sid As String
    Dim i As Integer
    Dim s As Variant
    sid = InputBox("请输入身份证号码:")
    i = Len(sid)
    If i <> 15 And i <> 18 Then
        MsgBox "身份证号码只能为15位或18位!"
        Exit Sub
    End If
    If i = 15 Then
        s = Right(sid, 1)
    Else
        s = Mid(sid, 17, 1)
    End If
    If Int(s / 2) = s / 2 Then
        sex = "女"
    Else
        sex = "男"
    End If
    MsgBox "性别:" + sex
End Sub