VBA 常用语法笔记

Option Explicit                     ' 强制变量声明

Sub DemoSub()
    MsgBox "执行完成"
End Sub

Function AddNum(a As Double, b As Double) As Double
    AddNum = a + b
End Function

Dim filePath As String
Dim lastRow As Long
Dim amount As Double
Dim isDone As Boolean
Dim dataArr As Variant
Dim ws As Worksheet
Const SHEET_NAME As String = "数据"

' 文件路径
ThisWorkbook.FullName               ' 完整路径
ThisWorkbook.Path                   ' 文件夹路径
ThisWorkbook.Name                   ' 文件名

' 绑定对象
Set wb = ThisWorkbook
Set ws = ThisWorkbook.Worksheets("Sheet1")

' 新建与修改
ThisWorkbook.Worksheets.Add
ws.Name = "汇总"
ws.Visible = xlSheetVeryHidden

' 打开与关闭
Set wb = Workbooks.Open("D:\data\源文件.xlsx")
wb.Close SaveChanges:=True
ThisWorkbook.Save
ThisWorkbook.SaveAs "D:\data\备份.xlsx"

' 取值与赋值
Range("A1").Value = "内容"
Cells(2, 1).Value = 1001
val = Range("A1").Value

' 动态区域
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
Set rng = Range("A2:B" & lastRow)
Set curRng = Range("A1").CurrentRegion

' 行列操作
Range("A:A").Value = Range("B:B").Value
Rows(2).Delete
Columns("C").Insert
Range("A1:C10").Copy Destination:=Range("E1")

' 一次性读取到数组（推荐）
dataArr = Range("A2:C100").Value

' 操作数组
UBound(dataArr, 1)                  ' 行数
LBound(dataArr, 1)                  ' 起始下标
res = dataArr(1, 2)                 ' 读取

' 写回工作表
Range("E2").Resize(UBound(dataArr, 1), UBound(dataArr, 2)).Value = dataArr

If Range("A1").Value = "" Then
    Exit Sub
End If

If val = "YL7" Then
    res = "高价值品"
ElseIf val = "YL026" Then
    res = "包装类"
Else
    res = "未定义"
End If

Select Case code
    Case "YL7"
        res = "高价值品"
    Case "YL026"
        res = "包装类"
    Case Else
        res = "未定义"
End Select

For i = 2 To lastRow
    Cells(i, 2).Value = "已处理"
Next i

For i = lastRow To 2 Step -1
    If Cells(i, 1).Value = "" Then Rows(i).Delete
Next i

For Each cell In Range("A2:A5")
    cell.Value = Trim(cell.Value)
Next cell

Do While n <= 3
    Debug.Print n
    n = n + 1
Loop

Exit For
Exit Do
Exit Sub
Exit Function

Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare

dict.Add "key", "value"              ' 添加
dict("key2") = "value2"              ' 添加/覆盖
dict.Exists("key")                   ' 判断是否存在
dict("key")                          ' 取值
dict.Count                           ' 数量
dict.Remove "key"                    ' 移除
dict.RemoveAll                       ' 清空

' 常见用途：去重与累计
For i = 2 To UBound(dataArr, 1)
    keyName = dataArr(i, 2) & "-" & dataArr(i, 9)
    If dict.Exists(keyName) Then
        dict(keyName) = dict(keyName) + CDbl(dataArr(i, 14))
    Else
        dict.Add keyName, CDbl(dataArr(i, 14))
    End If
Next i

Trim("  A001  ")                     ' 去空格
Left("ABCDEFG", 3)                   ' "ABC"
Right("ABCDEFG", 3)                  ' "EFG"
Mid("ABCDEFG", 2, 3)                 ' "BCD"
InStr("ABCDEFG", "CD")               ' 3
Replace("A-001", "-", "")            ' "A001"
Split("A,B,C", ",")                  ' 分割
Join(Array("A","B","C"), "-")        ' "A-B-C"
Format(1234.5, "0.00")               ' "1234.50"

Date                                 ' 当前日期
Time                                 ' 当前时间
Now                                  ' 当前日期时间
Year(Date)
Month(Date)
Day(Date)
DateAdd("d", 7, Date)                ' 加7天
DateDiff("d", d1, d2)                ' 日期差
DateSerial(2026, 5, 20)              ' 构造日期

' Find
Set foundCell = Range("A:A").Find(What:="目标", LookIn:=xlValues, LookAt:=xlWhole)

' AutoFilter
Range("A1:D100").AutoFilter Field:=2, Criteria1:="条件"
ActiveSheet.AutoFilterMode = False

' Sort
With ActiveSheet.Sort
    .SortFields.Clear
    .SortFields.Add Key:=Range("B2:B100"), Order:=xlAscending
    .SetRange Range("A1:D100")
    .Header = xlYes
    .Apply
End With

Application.WorksheetFunction.Sum(Range("A1:A10"))
Application.WorksheetFunction.CountA(Range("A1:A10"))
Application.WorksheetFunction.VLookup("A001", Range("F:G"), 2, False)
Application.WorksheetFunction.Match("目标", Range("A:A"), 0)
Application.WorksheetFunction.Index(Range("B:B"), 5)

Dir("D:\data\备份.xlsx")             ' 检查文件是否存在
MkDir "D:\data\归档"                 ' 创建文件夹
Kill "D:\data\临时文件.xlsx"          ' 删除文件

' 文本文件读写
fileNo = FreeFile
Open "D:\data\log.txt" For Output As #fileNo
Print #fileNo, "日志内容"
Close #fileNo

On Error GoTo ErrHandler
    ' 业务代码
Exit Sub

ErrHandler:
    MsgBox "错误信息：" & Err.Description
End Sub

' 恢复模式
On Error Resume Next                 ' 忽略错误继续执行
If Err.Number <> 0 Then
    Err.Clear
End If
On Error GoTo 0                      ' 恢复默认

' 执行前关闭
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual

' 执行后恢复
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic

' 释放对象
Set ws = Nothing
Set wb = Nothing
Set dict = Nothing
Erase dataArr

Option Explicit

Sub Main()
    On Error GoTo ErrHandler

    Dim ws As Worksheet
    Dim lastRow As Long
    Dim dataArr As Variant

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    dataArr = ws.Range("A2:C" & lastRow).Value

    ' 业务处理

SafeExit:
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Set ws = Nothing
    Erase dataArr
    Exit Sub

ErrHandler:
    MsgBox "错误：" & Err.Description, vbCritical
    Resume SafeExit
End Sub