VBA应用实例

1、用密码保护VBA代码不被非法执行

Sub Protect()
    Dim PW As Variant
    '一、密码校验部分
    PW = Application.InputBox("请输入密码", "Password Protected")
    
    Select Case PW
        '情况①：当用户取消(Cancel)输入
        Case Is = False
            'Do Nothing
            Exit Sub
        
        '情况②：当用户输入密码正确
        Case Is = "abc123"
            MsgBox "密码验证成功，将继续运行程序！"
            
        '情况③：当用户输入密码错误
        Case Else
            MsgBox "密码输入错误，不能执行本程序！"
            Exit Sub
    End Select
    
    '二、程序主体部分
    Rem VBA Codes...
End Sub

2、删除多余空白行

Sub 删除工作表中的空白行()
    Dim rRow As Long
    Dim LRow As Long
    Dim i As Long
    
    '获得工作表中已使用区域的首行行号，UsedRange属性返回工作表中已使用的区域。
    rRow = Sheets("明细账").UsedRange.Row
    
    '获得工作表中已使用区域的最后一行行号
    LRow = rRow + Sheets("明细账").UsedRange.Rows.Count - 1
    
    '从最大行数至最小行数循环判断空行
    For i = LRow To rRow Step -1
        '利用计数函数判断当前行内所有单元格是否为空
        If Application.WorksheetFunction.CountA(Rows(i)) = 0 Then
            Rows(i).Delete
        End If
    Next
End Sub

• UsedRange属性应用于Worksheet对象，返回指定工作表中已使用区域的Range对象，即返回工作表中已使用的单元格区域。
• WorksheetFunction.CountA 方法，用于计算非空单元格及参数列表中值的个数。

3、自动记录数据填写时间（时间戳）

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 1 And Target.Row >= 3 And Target.Count = 1 Then
        Target.Offset(0, 15).Value = Format(Now, "yyyy-mm-dd hh:mm:ss")
    End If
End Sub

4、ADO连接数据库

Sub Query()
    'Dim cnn As Object, rst As Object
    'Set cnn = CreateObject("ADODB.Connection")
    'Set rst = CreateObject("ADODB.Recordset")
    Dim cnn As New ADODB.Connection
    Dim rst As New ADODB.Recordset
    
    With cnn
        If Application.Version < 12 Then
            .Provider = "Microsoft.jet.OLEDB.4.0;Extended Properties='Excel 8.0;DHR=YES;IMEX=1'"
        Else
            .Provider = "Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=1'"
        End If
        .ConnectionString = ThisWorkbook.FullName
        .Open
    End With
	
	Dim strSQL As String, i As Integer
	strSQL = "SELECT * FROM [Sheet1$]"
	
    'Set rst = cnn.Execute(strSQL)
	rst.Open strSQL, cnn, adOpenKeyset, adLockOptimistic
	
    Sheet2.Cells.ClearContents	'清除内容
	
    For i = 0 To rst.Fields.Count - 1
        Sheet2.Cells(1, i + 1) = rst.Fields(i).Name
    Next
    Sheet2.Range("A2").CopyFromRecordset rst
    
    rst.Close: Set rst = Nothing
    cnn.Close: Set cnn = Nothing
End Sub

5、最后一个非空单元格

Sub lastcell()
    '选中最后一个非空单元格，等效于“Ctrl＋End”组合快捷键
    ActiveCell.SpecialCells(xlLastCell).Select
    '或者
    ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Select
End Sub

Sub lastcell()
    Dim x As Integer, y As Integer, rngCell As Range
    x = Sheet1.UsedRange.Rows.Count
    y = Sheet1.UsedRange.Columns.Count
    Set rngCell = Cells(x, y)
    
    rngCell.Select
End Sub

Sub coluLast()
    Dim x As Integer, y As Integer
    x = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    y = ActiveSheet.Range("A1").CurrentRegion.Rows.Count
    
    MsgBox x & "+" & y
    
    ActiveSheet.Cells(Rows.Count, 1).End(3).Select
    ActiveSheet.Range("A1048576").End(xlUp).Select
End Sub

6、自动填充

Sub 自动填充()
    With Range("A1")
        .Value = "1月"
        .Borders.LineStyle = xlContinuous
        .AutoFill Destination:=Range("A1:A12")
    End With
    Range("A1:A12").AutoFill Destination:=Range("A1:D12"), Type:=xlFillFormats
End Sub

7、代码窗口键盘快捷键

功能	快捷键
属性/方法列表	Ctrl＋J
快速信息	Ctrl＋I
参数信息	Ctrl＋Shift＋I
对象浏览器	F2
属性窗口	F4
立即窗口	Ctrl＋G
工程浏览器	Ctrl＋R
运行子过程/用户窗体	F5
逐语句运行代码	F8
运行到光标处	Ctrl＋F8
切换断点	F9
清除所有断点	Ctrl＋Shift＋F9