📘 VBA 完整指南

' 这是单行注释 Rem 这也是单行注释 Sub ExampleSub() ' 函数内的注释 MsgBox "Hello World" ' 行尾注释 End Sub

' 过程 (Sub) - 不返回值 Sub MyProcedure() ' 代码逻辑 MsgBox "这是一个过程" End Sub ' 函数 (Function) - 返回值 Function MyFunction() As String MyFunction = "这是一个函数" End Function ' 调用过程和函数 Sub TestCalls() Call MyProcedure ' 调用过程 ' 或者直接调用 MyProcedure ' 调用函数并获取返回值 Dim result As String result = MyFunction() MsgBox result End Sub

Sub VariableDeclaration() ' 声明变量 Dim name As String Dim age As Integer Dim salary As Double Dim isActive As Boolean ' 赋值 name = "张三" age = 25 salary = 5000.5 isActive = True ' 常量声明 Const PI As Double = 3.14159 Const COMPANY_NAME As String = "ABC公司" ' 输出变量值 Debug.Print "姓名: " & name Debug.Print "年龄: " & age Debug.Print "工资: " & salary Debug.Print "状态: " & isActive End Sub

' 模块级变量 (在模块顶部声明) Public globalVar As String Private moduleVar As Integer Sub ScopeExample() ' 局部变量 (仅在此过程中有效) Dim localVar As String localVar = "局部变量" ' 静态变量 (保持值在多次调用之间) Static counter As Integer counter = counter + 1 Debug.Print "调用次数: " & counter End Sub

Sub InputOutputExample() ' 消息框 MsgBox "这是一个消息框" MsgBox "标题消息", vbInformation, "信息" ' 输入框 Dim userName As String userName = InputBox("请输入您的姓名:", "用户输入") If userName <> "" Then MsgBox "您好, " & userName & "!" End If ' 调试输出 (在立即窗口中显示) Debug.Print "调试信息: " & Now() End Sub

Sub DataTypeExamples() ' 数值类型 Dim byteVar As Byte: byteVar = 255 Dim intVar As Integer: intVar = 32000 Dim longVar As Long: longVar = 2000000 Dim singleVar As Single: singleVar = 3.14 Dim doubleVar As Double: doubleVar = 3.141592653589793 ' 货币类型 Dim price As Currency: price = 1234.56 ' 布尔类型 Dim isTrue As Boolean: isTrue = True ' 日期类型 Dim today As Date: today = Now() Dim birthday As Date: birthday = #1/1/1990# ' 字符串类型 Dim text As String: text = "Hello VBA" Dim fixedString As String * 10: fixedString = "Fixed" ' Variant 类型 (可以存储任何类型) Dim anyType As Variant anyType = 100 anyType = "现在是字符串" anyType = True ' 输出类型信息 Debug.Print "Byte: " & byteVar Debug.Print "Integer: " & intVar Debug.Print "Long: " & longVar Debug.Print "Single: " & singleVar Debug.Print "Double: " & doubleVar Debug.Print "Currency: " & Format(price, "Currency") Debug.Print "Boolean: " & isTrue Debug.Print "Date: " & Format(today, "yyyy-mm-dd hh:mm:ss") Debug.Print "String: " & text End Sub

Sub TypeConversion() Dim strNumber As String: strNumber = "123" Dim strFloat As String: strFloat = "45.67" Dim strDate As String: strDate = "2023-12-25" ' 字符串转数值 Dim intValue As Integer: intValue = CInt(strNumber) Dim longValue As Long: longValue = CLng(strNumber) Dim doubleValue As Double: doubleValue = CDbl(strFloat) ' 字符串转日期 Dim dateValue As Date: dateValue = CDate(strDate) ' 数值转字符串 Dim numStr As String: numStr = CStr(intValue) ' 其他转换 Dim boolValue As Boolean: boolValue = CBool(1) ' True Dim byteValue As Byte: byteValue = CByte(255) ' 类型检查 If IsNumeric(strNumber) Then Debug.Print strNumber & " 是数值" End If If IsDate(strDate) Then Debug.Print strDate & " 是日期" End If ' 输出结果 Debug.Print "转换结果:" Debug.Print "Int: " & intValue Debug.Print "Double: " & doubleValue Debug.Print "Date: " & dateValue Debug.Print "String: " & numStr End Sub

Sub ArithmeticOperators() Dim a As Integer: a = 10 Dim b As Integer: b = 3 ' 基本算术运算 Debug.Print "加法: " & a & " + " & b & " = " & (a + b) ' 13 Debug.Print "减法: " & a & " - " & b & " = " & (a - b) ' 7 Debug.Print "乘法: " & a & " * " & b & " = " & (a * b) ' 30 Debug.Print "除法: " & a & " / " & b & " = " & (a / b) ' 3.33333 Debug.Print "整除: " & a & " \ " & b & " = " & (a \ b) ' 3 Debug.Print "取模: " & a & " Mod " & b & " = " & (a Mod b) ' 1 Debug.Print "乘方: " & a & " ^ 2 = " & (a ^ 2) ' 100 ' 负数 Debug.Print "负数: -" & a & " = " & (-a) ' -10 End Sub

Sub ComparisonOperators() Dim x As Integer: x = 5 Dim y As Integer: y = 3 Dim str1 As String: str1 = "Apple" Dim str2 As String: str2 = "Banana" ' 数值比较 Debug.Print x & " = " & y & " : " & (x = y) ' False Debug.Print x & " <> " & y & " : " & (x <> y) ' True Debug.Print x & " > " & y & " : " & (x > y) ' True Debug.Print x & " < " & y & " : " & (x < y) ' False Debug.Print x & " >= " & y & " : " & (x >= y) ' True Debug.Print x & " <= " & y & " : " & (x <= y) ' False ' 字符串比较 Debug.Print str1 & " = " & str2 & " : " & (str1 = str2) ' False Debug.Print str1 & " < " & str2 & " : " & (str1 < str2) ' True (字母顺序) ' Like 运算符 (模式匹配) Dim testStr As String: testStr = "Hello World" Debug.Print testStr & " Like ""H*"" : " & (testStr Like "H*") ' True Debug.Print testStr & " Like ""*World"" : " & (testStr Like "*World") ' True Debug.Print testStr & " Like ""H?llo*"" : " & (testStr Like "H?llo*") ' True End Sub

Sub LogicalOperators() Dim a As Boolean: a = True Dim b As Boolean: b = False Dim x As Integer: x = 5 Dim y As Integer: y = 3 ' 基本逻辑运算 Debug.Print "And: " & a & " And " & b & " = " & (a And b) ' False Debug.Print "Or: " & a & " Or " & b & " = " & (a Or b) ' True Debug.Print "Not: Not " & a & " = " & (Not a) ' False Debug.Print "Xor: " & a & " Xor " & b & " = " & (a Xor b) ' True ' 复合条件 If (x > 0) And (y > 0) Then Debug.Print "两个数都是正数" End If If (x > 10) Or (y > 10) Then Debug.Print "至少有一个数大于10" Else Debug.Print "两个数都不大于10" End If ' 位运算 Dim num1 As Integer: num1 = 12 ' 二进制: 1100 Dim num2 As Integer: num2 = 7 ' 二进制: 0111 Debug.Print "位与: " & num1 & " And " & num2 & " = " & (num1 And num2) ' 4 (0100) Debug.Print "位或: " & num1 & " Or " & num2 & " = " & (num1 Or num2) ' 15 (1111) End Sub

Sub StringOperators() Dim firstName As String: firstName = "张" Dim lastName As String: lastName = "三" ' 字符串连接 Dim fullName1 As String: fullName1 = firstName + lastName ' 张三 Dim fullName2 As String: fullName2 = firstName & lastName ' 张三 ' & 运算符更安全，推荐使用 Dim age As Integer: age = 25 Dim info As String: info = "姓名: " & fullName1 & ", 年龄: " & age Debug.Print "全名1: " & fullName1 Debug.Print "全名2: " & fullName2 Debug.Print "信息: " & info ' 与数值混合时的区别 Dim result1 As String: result1 = "5" + "3" ' "53" (字符串连接) Dim result2 As Integer: result2 = 5 + 3 ' 8 (数值相加) Debug.Print "字符串相加: " & result1 Debug.Print "数值相加: " & result2 End Sub

Sub OperatorPrecedence() ' 运算符优先级 (从高到低): ' 1. 括号 () ' 2. 乘方 ^ ' 3. 负号 - ' 4. 乘除 *, / ' 5. 整除 \ ' 6. 取模 Mod ' 7. 加减 +, - ' 8. 字符串连接 & ' 9. 比较运算符 =, <>, <, >, <=, >=, Like ' 10. 逻辑运算符 Not, And, Or, Xor Dim result As Double ' 不使用括号 result = 2 + 3 * 4 ' 结果: 14 (先乘后加) Debug.Print "2 + 3 * 4 = " & result ' 使用括号改变优先级 result = (2 + 3) * 4 ' 结果: 20 (先加后乘) Debug.Print "(2 + 3) * 4 = " & result ' 复杂表达式 result = 2 ^ 3 + 4 * 5 - 6 / 2 ' 结果: 8 + 20 - 3 = 25 Debug.Print "2 ^ 3 + 4 * 5 - 6 / 2 = " & result ' 逻辑运算优先级 Dim a As Boolean: a = True Dim b As Boolean: b = False Dim c As Boolean: c = True Dim logicResult As Boolean logicResult = a Or b And c ' 结果: True (And 优先级高于 Or) Debug.Print "True Or False And True = " & logicResult logicResult = (a Or b) And c ' 结果: True Debug.Print "(True Or False) And True = " & logicResult End Sub

Sub IfStatements() Dim score As Integer score = 85 ' 简单 If 语句 If score >= 60 Then Debug.Print "及格" End If ' If...Else 语句 If score >= 90 Then Debug.Print "优秀" Else Debug.Print "需要努力" End If ' If...ElseIf...Else 语句 If score >= 90 Then Debug.Print "等级: A" ElseIf score >= 80 Then Debug.Print "等级: B" ElseIf score >= 70 Then Debug.Print "等级: C" ElseIf score >= 60 Then Debug.Print "等级: D" Else Debug.Print "等级: F" End If ' 嵌套 If 语句 Dim age As Integer: age = 20 If age >= 18 Then If score >= 60 Then Debug.Print "成年且及格" Else Debug.Print "成年但不及格" End If Else Debug.Print "未成年" End If ' 单行 If 语句 If score >= 90 Then Debug.Print "单行条件: 优秀" End Sub

Sub SelectCaseExample() Dim dayOfWeek As Integer dayOfWeek = Weekday(Now()) ' 1=Sunday, 2=Monday, etc. Select Case dayOfWeek Case 1 Debug.Print "今天是周日" Case 2 Debug.Print "今天是周一" Case 3 To 6 Debug.Print "今天是工作日" Case 7 Debug.Print "今天是周六" Case Else Debug.Print "无效的日期" End Select ' 字符串 Select Case Dim grade As String: grade = "B" Select Case UCase(grade) Case "A" Debug.Print "优秀" Case "B", "C" Debug.Print "良好" Case "D" Debug.Print "及格" Case "F" Debug.Print "不及格" Case Else Debug.Print "无效等级" End Select ' 条件表达式 Dim temperature As Integer: temperature = 25 Select Case temperature Case Is < 0 Debug.Print "冰点以下" Case 0 To 10 Debug.Print "寒冷" Case 11 To 25 Debug.Print "凉爽" Case 26 To 35 Debug.Print "温暖" Case Is > 35 Debug.Print "炎热" End Select End Sub

Sub ForLoops() Dim i As Integer ' 基本 For 循环 Debug.Print "基本 For 循环:" For i = 1 To 5 Debug.Print "i = " & i Next i ' 指定步长 Debug.Print "步长为 2:" For i = 0 To 10 Step 2 Debug.Print i Next i ' 倒序循环 Debug.Print "倒序循环:" For i = 5 To 1 Step -1 Debug.Print i Next i ' 嵌套循环 Debug.Print "嵌套循环 (乘法表):" Dim j As Integer For i = 1 To 3 For j = 1 To 3 Debug.Print i & " x " & j & " = " & (i * j) Next j Next i ' For Each 循环 (用于数组和集合) Dim numbers() As Integer ReDim numbers(1 To 5) numbers(1) = 10: numbers(2) = 20: numbers(3) = 30 numbers(4) = 40: numbers(5) = 50 Debug.Print "For Each 循环:" Dim num As Variant For Each num In numbers Debug.Print "数值: " & num Next num End Sub

Sub DoLoops() Dim counter As Integer ' Do While 循环 (先判断条件) Debug.Print "Do While 循环:" counter = 1 Do While counter <= 3 Debug.Print "Counter: " & counter counter = counter + 1 Loop ' Do Until 循环 (先判断条件) Debug.Print "Do Until 循环:" counter = 1 Do Until counter > 3 Debug.Print "Counter: " & counter counter = counter + 1 Loop ' Do...Loop While (后判断条件) Debug.Print "Do...Loop While:" counter = 1 Do Debug.Print "Counter: " & counter counter = counter + 1 Loop While counter <= 3 ' Do...Loop Until (后判断条件) Debug.Print "Do...Loop Until:" counter = 1 Do Debug.Print "Counter: " & counter counter = counter + 1 Loop Until counter > 3 ' 无限循环示例 (需要 Exit Do 退出) Debug.Print "带退出条件的循环:" counter = 1 Do Debug.Print "Counter: " & counter counter = counter + 1 If counter > 3 Then Exit Do Loop End Sub

Sub WhileLoop() Dim i As Integer: i = 1 Debug.Print "While...Wend 循环:" While i <= 5 Debug.Print "i = " & i i = i + 1 Wend End Sub

Sub LoopControl() Dim i As Integer, j As Integer ' Exit For - 退出 For 循环 Debug.Print "Exit For 示例:" For i = 1 To 10 If i = 5 Then Exit For Debug.Print i Next i ' Exit Do - 退出 Do 循环 Debug.Print "Exit Do 示例:" i = 1 Do If i = 3 Then Exit Do Debug.Print i i = i + 1 Loop ' GoTo 语句 (不推荐使用，但有时必要) Debug.Print "GoTo 示例:" For i = 1 To 5 If i = 3 Then GoTo SkipThree Debug.Print i GoTo ContinueLoop SkipThree: Debug.Print "跳过 " & i ContinueLoop: Next i ' 嵌套循环中的退出 Debug.Print "嵌套循环退出:" For i = 1 To 3 For j = 1 To 3 If i = 2 And j = 2 Then Exit For ' 只退出内层循环 Debug.Print "i=" & i & ", j=" & j Next j Next i End Sub

' 简单过程 Sub SayHello() MsgBox "Hello, VBA!" End Sub ' 带参数的过程 Sub GreetUser(userName As String) MsgBox "你好, " & userName & "!" End Sub ' 多个参数的过程 Sub CalculateArea(length As Double, width As Double) Dim area As Double area = length * width Debug.Print "长度: " & length & ", 宽度: " & width Debug.Print "面积: " & area End Sub ' 可选参数 Sub DisplayMessage(message As String, Optional title As String = "信息") MsgBox message, vbInformation, title End Sub ' 使用示例 Sub CallSubExamples() ' 调用简单过程 Call SayHello ' 或者直接调用 SayHello ' 调用带参数的过程 Call GreetUser("张三") GreetUser "李四" ' Call 关键字可省略 ' 调用多参数过程 CalculateArea 10.5, 8.3 ' 调用可选参数过程 DisplayMessage "这是一条消息" DisplayMessage "这是另一条消息", "警告" End Sub

' 简单函数 Function GetCurrentTime() As String GetCurrentTime = Format(Now(), "yyyy-mm-dd hh:mm:ss") End Function ' 带参数的函数 Function AddNumbers(num1 As Double, num2 As Double) As Double AddNumbers = num1 + num2 End Function ' 复杂计算函数 Function CalculateCircleArea(radius As Double) As Double Const PI As Double = 3.14159265359 CalculateCircleArea = PI * radius * radius End Function ' 字符串处理函数 Function ReverseString(inputStr As String) As String Dim i As Integer Dim result As String For i = Len(inputStr) To 1 Step -1 result = result & Mid(inputStr, i, 1) Next i ReverseString = result End Function ' 条件判断函数 Function GetGrade(score As Integer) As String Select Case score Case 90 To 100 GetGrade = "A" Case 80 To 89 GetGrade = "B" Case 70 To 79 GetGrade = "C" Case 60 To 69 GetGrade = "D" Case Else GetGrade = "F" End Select End Function ' 使用函数示例 Sub CallFunctionExamples() ' 调用并使用返回值 Dim currentTime As String currentTime = GetCurrentTime() Debug.Print "当前时间: " & currentTime ' 直接在表达式中使用函数 Debug.Print "5 + 3 = " & AddNumbers(5, 3) ' 函数嵌套调用 Debug.Print "半径为5的圆面积: " & CalculateCircleArea(5) ' 字符串函数 Debug.Print "VBA 反转: " & ReverseString("VBA") ' 条件函数 Debug.Print "85分的等级: " & GetGrade(85) End Sub

' 按值传递 (ByVal) - 默认方式，不会修改原变量 Sub TestByVal(ByVal num As Integer) num = num * 2 Debug.Print "函数内 num = " & num End Sub ' 按引用传递 (ByRef) - 会修改原变量 Sub TestByRef(ByRef num As Integer) num = num * 2 Debug.Print "函数内 num = " & num End Sub ' 混合参数类型 Sub MixedParameters(ByVal readOnly As String, ByRef modifiable As Integer) readOnly = "不会改变" ' 不影响原变量 modifiable = modifiable + 10 ' 会修改原变量 End Sub ' 参数数组 Sub SumNumbers(ParamArray numbers() As Variant) Dim i As Integer Dim total As Double For i = LBound(numbers) To UBound(numbers) total = total + numbers(i) Next i Debug.Print "总和: " & total End Sub ' 测试参数传递 Sub TestParameters() Dim value1 As Integer: value1 = 10 Dim value2 As Integer: value2 = 10 Debug.Print "原始值: value1=" & value1 & ", value2=" & value2 ' 按值传递 TestByVal value1 Debug.Print "ByVal 后: value1=" & value1 ' 仍然是 10 ' 按引用传递 TestByRef value2 Debug.Print "ByRef 后: value2=" & value2 ' 变成 20 ' 参数数组测试 SumNumbers 1, 2, 3, 4, 5 SumNumbers 10, 20, 30 End Sub

' 计算阶乘的递归函数 Function Factorial(n As Integer) As Long If n <= 1 Then Factorial = 1 Else Factorial = n * Factorial(n - 1) End If End Function ' 斐波那契数列 Function Fibonacci(n As Integer) As Long If n <= 2 Then Fibonacci = 1 Else Fibonacci = Fibonacci(n - 1) + Fibonacci(n - 2) End If End Function ' 递归查找最大值 Function FindMax(arr() As Integer, startIndex As Integer, endIndex As Integer) As Integer If startIndex = endIndex Then FindMax = arr(startIndex) Else Dim mid As Integer mid = (startIndex + endIndex) \ 2 Dim leftMax As Integer: leftMax = FindMax(arr, startIndex, mid) Dim rightMax As Integer: rightMax = FindMax(arr, mid + 1, endIndex) If leftMax > rightMax Then FindMax = leftMax Else FindMax = rightMax End If End If End Function ' 递归函数测试 Sub TestRecursion() ' 阶乘测试 Debug.Print "5! = " & Factorial(5) ' 120 ' 斐波那契测试 Debug.Print "第8个斐波那契数: " & Fibonacci(8) ' 21 ' 查找最大值测试 Dim numbers(1 To 7) As Integer numbers(1) = 3: numbers(2) = 7: numbers(3) = 2 numbers(4) = 9: numbers(5) = 1: numbers(6) = 8: numbers(7) = 4 Debug.Print "数组最大值: " & FindMax(numbers, 1, 7) ' 9 End Sub

' 带错误处理的函数 Function SafeDivide(numerator As Double, denominator As Double) As Variant On Error GoTo ErrorHandler If denominator = 0 Then SafeDivide = "除数不能为零" Else SafeDivide = numerator / denominator End If Exit Function ErrorHandler: SafeDivide = "计算出错: " & Err.Description End Function ' 文件操作错误处理 Function ReadTextFile(filePath As String) As String On Error GoTo ErrorHandler Dim fileNum As Integer Dim fileContent As String fileNum = FreeFile Open filePath For Input As fileNum fileContent = Input(LOF(fileNum), fileNum) Close fileNum ReadTextFile = fileContent Exit Function ErrorHandler: If fileNum <> 0 Then Close fileNum ReadTextFile = "错误: " & Err.Description End Function ' 测试错误处理 Sub TestErrorHandling() ' 测试除法 Debug.Print "10 / 2 = " & SafeDivide(10, 2) Debug.Print "10 / 0 = " & SafeDivide(10, 0) ' 测试文件读取 Debug.Print ReadTextFile("C:\不存在的文件.txt") End Sub

Sub ApplicationObjectExample() ' 获取应用程序信息 Debug.Print "应用程序名称: " & Application.Name Debug.Print "版本: " & Application.Version Debug.Print "用户名: " & Application.UserName Debug.Print "操作系统: " & Application.OperatingSystem ' 控制应用程序行为 Application.ScreenUpdating = False ' 关闭屏幕更新 Application.Calculation = xlCalculationManual ' 手动计算模式 Application.DisplayAlerts = False ' 关闭警告对话框 ' 工作簿操作 Dim wb As Workbook Set wb = Application.Workbooks.Add ' 创建新工作簿 ' 恢复设置 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.DisplayAlerts = True ' 应用程序路径 Debug.Print "Excel 路径: " & Application.Path Debug.Print "启动路径: " & Application.StartupPath ' 关闭工作簿 wb.Close SaveChanges:=False End Sub

Sub WorkbookObjectExample() Dim wb As Workbook ' 创建新工作簿 Set wb = Workbooks.Add ' 工作簿属性 wb.Title = "示例工作簿" wb.Subject = "VBA 教程" wb.Author = "VBA 学习者" Debug.Print "工作簿名称: " & wb.Name Debug.Print "完整路径: " & wb.FullName Debug.Print "工作表数量: " & wb.Worksheets.Count ' 保存工作簿 wb.SaveAs "C:\Temp\示例工作簿.xlsx" ' 工作簿事件 (需要在工作簿模块中编写) ' Private Sub Workbook_Open() ' MsgBox "工作簿已打开" ' End Sub ' 关闭工作簿 wb.Close SaveChanges:=True ' 打开现有工作簿 If Dir("C:\Temp\示例工作簿.xlsx") <> "" Then Set wb = Workbooks.Open("C:\Temp\示例工作簿.xlsx") Debug.Print "工作簿已打开: " & wb.Name wb.Close SaveChanges:=False End If End Sub

Sub WorksheetObjectExample() Dim ws As Worksheet ' 引用工作表的不同方式 Set ws = ActiveSheet ' 当前活动工作表 Set ws = Worksheets("Sheet1") ' 按名称引用 Set ws = Worksheets(1) ' 按索引引用 Set ws = ThisWorkbook.Worksheets(1) ' 指定工作簿中的工作表 ' 工作表属性 ws.Name = "数据表" ws.Tab.Color = RGB(255, 0, 0) ' 设置标签颜色为红色 Debug.Print "工作表名称: " & ws.Name Debug.Print "可见状态: " & ws.Visible Debug.Print "使用区域: " & ws.UsedRange.Address ' 添加新工作表 Dim newWs As Worksheet Set newWs = Worksheets.Add(After:=ws) newWs.Name = "新工作表" ' 复制工作表 ws.Copy After:=newWs ' 删除工作表 (需要关闭警告对话框) Application.DisplayAlerts = False newWs.Delete Application.DisplayAlerts = True ' 保护工作表 ws.Protect Password:="123456", DrawingObjects:=True, Contents:=True ' 取消保护 ws.Unprotect Password:="123456" ' 工作表事件 (需要在工作表模块中编写) ' Private Sub Worksheet_Change(ByVal Target As Range) ' MsgBox "单元格 " & Target.Address & " 已更改" ' End Sub End Sub

Sub RangeObjectExample() Dim ws As Worksheet Set ws = ActiveSheet Dim rng As Range ' 引用单元格区域的不同方式 Set rng = ws.Range("A1") ' 单个单元格 Set rng = ws.Range("A1:C3") ' 区域 Set rng = ws.Range("A1,B1,C1") ' 不连续区域 Set rng = ws.Range("A:A") ' 整列 Set rng = ws.Range("1:1") ' 整行 Set rng = ws.Range("A1").CurrentRegion ' 当前区域(连续数据) Set rng = ws.UsedRange ' 已使用区域 ' 通过行列号引用 Set rng = ws.Cells(1, 1) ' A1 Set rng = ws.Cells(2, 3) ' C2 ' 通过名称引用 ws.Names.Add Name:="MyRange", RefersTo:="=Sheet1!$A$1:$C$3" Set rng = ws.Range("MyRange") ' 常用属性和方法 rng.Value = "Hello VBA" ' 设置值 rng.Font.Bold = True ' 设置字体 rng.Interior.Color = RGB(255, 255, 0) ' 设置背景色 ' 遍历区域 Dim cell As Range For Each cell In rng Debug.Print cell.Address & ": " & cell.Value Next cell ' 特殊单元格 Set rng = ws.Cells.SpecialCells(xlCellTypeConstants) ' 所有常量单元格 Set rng = ws.Cells.SpecialCells(xlCellTypeFormulas) ' 所有公式单元格 ' 清除内容 rng.ClearContents rng.ClearFormats rng.Clear End Sub

Sub CellOperations() Dim ws As Worksheet Set ws = ActiveSheet ' 基本单元格操作 ws.Range("A1").Value = "姓名" ws.Range("B1").Value = "年龄" ws.Range("A2").Value = "张三" ws.Range("B2").Value = 25 ' 批量填充数据 ws.Range("A3:A10").Value = "批量填充" ws.Range("B3:B10").Formula = "=RANDBETWEEN(20,60)" ' 格式设置 With ws.Range("A1:B1") .Font.Bold = True .Interior.Color = RGB(200, 200, 200) .HorizontalAlignment = xlCenter End With ' 自动调整列宽 ws.Columns("A:B").AutoFit ' 条件格式 With ws.Range("B2:B10").FormatConditions.Add(Type:=xlCellValue, Operator:=xlGreater, Formula1:="50") .Font.Bold = True .Font.Color = RGB(255, 0, 0) End With ' 数据验证 With ws.Range("C2:C10").Validation .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="男,女" .InputTitle = "性别选择" .InputMessage = "请选择性别" End With ' 合并单元格 ws.Range("D1:E1").Merge ws.Range("D1").Value = "合并单元格" End Sub

Sub DataProcessing() Dim ws As Worksheet Set ws = ActiveSheet ' 填充测试数据 Dim i As Integer For i = 1 To 10 ws.Cells(i + 1, 1).Value = "产品" & i ws.Cells(i + 1, 2).Value = Rnd() * 100 Next i ' 排序 ws.Range("A1:B11").Sort Key1:=ws.Range("B2"), Order1:=xlDescending ' 筛选 ws.Range("A1:B11").AutoFilter Field:=2, Criteria1:=">50" ' 数据透视表 Dim ptCache As PivotCache Dim pt As PivotTable Dim pf As PivotField ' 创建数据透视表缓存 Set ptCache = ThisWorkbook.PivotCaches.Create( _ SourceType:=xlDatabase, _ SourceData:=ws.Range("A1:B11")) ' 创建数据透视表 Set pt = ptCache.CreatePivotTable( _ TableDestination:=ws.Range("D1"), _ TableName:="销售分析") ' 添加字段 With pt .AddFields RowFields:="产品" Set pf = .AddDataField(.PivotFields("销售额"), "总销售额", xlSum) End With ' 高级筛选 ws.Range("F1").Value = "销售额" ws.Range("F2").Value = ">50" ws.Range("A1:B11").AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=ws.Range("F1:F2"), _ CopyToRange:=ws.Range("H1"), _ Unique:=False End Sub

Sub ChartOperations() Dim ws As Worksheet Set ws = ActiveSheet ' 准备数据 Dim i As Integer For i = 1 To 12 ws.Cells(i + 1, 1).Value = i & "月" ws.Cells(i + 1, 2).Value = Rnd() * 1000 Next i ' 创建图表 Dim cht As ChartObject Set cht = ws.ChartObjects.Add(Left:=100, Width:=400, Top:=50, Height:=250) ' 设置图表类型和数据 With cht.Chart .ChartType = xlColumnClustered .SetSourceData Source:=ws.Range("A2:B13") .HasTitle = True .ChartTitle.Text = "月度销售报表" ' 设置轴标题 .Axes(xlCategory).HasTitle = True .Axes(xlCategory).AxisTitle.Text = "月份" .Axes(xlValue).HasTitle = True .Axes(xlValue).AxisTitle.Text = "销售额" ' 设置数据标签 .SeriesCollection(1).ApplyDataLabels End With ' 创建饼图 Dim pieChart As ChartObject Set pieChart = ws.ChartObjects.Add(Left:=550, Width:=300, Top:=50, Height:=250) With pieChart.Chart .ChartType = xlPie .SetSourceData Source:=ws.Range("A2:B7") .HasTitle = True .ChartTitle.Text = "上半年销售占比" .SeriesCollection(1).ApplyDataLabels ShowPercentage:=True End With End Sub

Sub AdvancedFeatures() Dim ws As Worksheet Set ws = ActiveSheet ' 1. 数组公式 ws.Range("C2:C11").FormulaArray = "=A2:A11*B2:B11" ' 2. 自定义函数 ws.Range("D2:D11").Formula = "=MYCUSTOMFUNCTION(A2,B2)" ' 3. 事件处理 ' 在工作表模块中添加: ' Private Sub Worksheet_Change(ByVal Target As Range) ' If Not Intersect(Target, Range("A1:A10")) Is Nothing Then ' MsgBox "A1:A10区域被修改" ' End If ' End Sub ' 4. 使用Windows API ' 声明API函数 ' Private Declare PtrSafe Function MessageBox Lib "user32" Alias "MessageBoxA" _ ' (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, _ ' ByVal wType As Long) As Long ' 5. 自动化其他Office应用 Dim wordApp As Object Set wordApp = CreateObject("Word.Application") wordApp.Visible = True wordApp.Documents.Add wordApp.Selection.TypeText "这是从Excel自动创建的Word文档" ' wordApp.Quit ' Set wordApp = Nothing ' 6. 使用ADO连接数据库 ' Dim conn As Object ' Set conn = CreateObject("ADODB.Connection") ' conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\mydb.accdb;" ' Dim rs As Object ' Set rs = conn.Execute("SELECT * FROM Customers") ' ws.Range("A1").CopyFromRecordset rs ' rs.Close ' conn.Close End Sub ' 自定义函数示例 Function MYCUSTOMFUNCTION(a As Variant, b As Variant) As Variant MYCUSTOMFUNCTION = a * 1.1 + b * 0.9 End Function

Sub PerformanceOptimization() Dim startTime As Double startTime = Timer Dim ws As Worksheet Set ws = ActiveSheet ' 1. 关闭屏幕更新 Application.ScreenUpdating = False ' 2. 禁用自动计算 Application.Calculation = xlCalculationManual ' 3. 禁用事件 Application.EnableEvents = False ' 4. 使用数组处理数据 Dim dataArray() As Variant dataArray = ws.Range("A1:B10000").Value Dim i As Long For i = LBound(dataArray, 1) To UBound(dataArray, 1) dataArray(i, 2) = dataArray(i, 1) * 1.1 Next i ws.Range("A1:B10000").Value = dataArray ' 5. 批量操作单元格 With ws.Range("C1:C10000") .Value = "=A1*B1" .Value = .Value ' 将公式转换为值 End With ' 恢复设置 Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Debug.Print "执行时间: " & Round(Timer - startTime, 2) & "秒" End Sub

' 创建和显示用户窗体 Sub ShowUserForm() ' 加载并显示窗体 UserForm1.Show ' 以模态方式显示(默认) ' UserForm1.Show vbModal ' 以非模态方式显示 ' UserForm1.Show vbModeless ' 加载但不显示 ' Load UserForm1 ' UserForm1.Show End Sub ' 窗体初始化事件 Private Sub UserForm_Initialize() ' 设置窗体属性 Me.Caption = "我的窗体" Me.BackColor = RGB(240, 240, 240) Me.Width = 400 Me.Height = 300 ' 添加控件 Dim btn As MSForms.CommandButton Set btn = Me.Controls.Add("Forms.CommandButton.1", "btnClose") With btn .Caption = "关闭" .Left = 150 .Top = 200 .Width = 80 .Height = 24 End With End Sub ' 窗体关闭事件 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = vbFormControlMenu Then MsgBox "请使用关闭按钮退出", vbInformation Cancel = True End If End Sub

' 文本框控件 Private Sub TextBox1_Change() Label1.Caption = "输入内容: " & TextBox1.Text End Sub ' 组合框和列表框 Private Sub UserForm_Initialize() ' 填充组合框 With ComboBox1 .AddItem "选项1" .AddItem "选项2" .AddItem "选项3" .ListIndex = 0 ' 默认选择第一项 End With ' 填充列表框 With ListBox1 .AddItem "项目A" .AddItem "项目B" .AddItem "项目C" .MultiSelect = fmMultiSelectMulti ' 允许多选 End With End Sub ' 复选框和单选按钮 Private Sub CheckBox1_Click() If CheckBox1.Value = True Then MsgBox "复选框已选中" End If End Sub Private Sub OptionButton1_Click() If OptionButton1.Value = True Then MsgBox "选项1被选中" End If End Sub ' 命令按钮 Private Sub CommandButton1_Click() Dim selectedItems As String Dim i As Integer ' 获取列表框中的多选项目 For i = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(i) Then selectedItems = selectedItems & ListBox1.List(i) & vbCrLf End If Next i MsgBox "你选择了:" & vbCrLf & selectedItems End Sub

' 多页控件 Private Sub MultiPage1_Change() Select Case MultiPage1.Value Case 0 ' 第一页 Label1.Caption = "当前页: 基本信息" Case 1 ' 第二页 Label1.Caption = "当前页: 高级设置" End Select End Sub ' 图像控件 Private Sub CommandButton2_Click() Dim filePath As String filePath = Application.GetOpenFilename("图片文件 (*.jpg;*.png), *.jpg;*.png") If filePath <> "False" Then Image1.Picture = LoadPicture(filePath) End If End Sub ' 进度条控件(需要Windows API) Private Declare PtrSafe Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" _ (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, _ ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _ ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, _ ByVal hInstance As Long, ByVal lpParam As Long) As Long Private Sub ShowProgress() ' 创建进度条窗体 Dim progressForm As UserForm Set progressForm = New UserForm With progressForm .Caption = "处理中..." .Width = 300 .Height = 100 ' 添加标签 Dim lbl As MSForms.Label Set lbl = .Controls.Add("Forms.Label.1", "lblProgress") lbl.Caption = "0% 完成" lbl.Left = 20 lbl.Top = 10 lbl.Width = 260 ' 添加进度条 Dim pb As MSForms.Frame Set pb = .Controls.Add("Forms.Frame.1", "frameProgress") pb.BorderStyle = fmBorderStyleNone pb.BackColor = RGB(200, 200, 200) pb.Left = 20 pb.Top = 30 pb.Width = 260 pb.Height = 20 Dim pbInner As MSForms.Label Set pbInner = pb.Controls.Add("Forms.Label.1", "pbInner") pbInner.BackColor = RGB(0, 176, 80) pbInner.Left = 0 pbInner.Top = 0 pbInner.Width = 0 pbInner.Height = 20 End With ' 显示窗体(非模态) progressForm.Show vbModeless ' 模拟进度更新 Dim i As Integer For i = 1 To 100 DoEvents ' 允许窗体更新 progressForm.Controls("pbInner").Width = i * 2.6 progressForm.Controls("lblProgress").Caption = i & "% 完成" Application.Wait Now + TimeValue("00:00:0.05") ' 延迟 Next i Unload progressForm End Sub

' 绑定数据到列表框 Private Sub BindDataToListBox() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("数据") Dim rng As Range Set rng = ws.Range("A2:A10") ' 假设A列有数据 ' 清空列表框 ListBox1.Clear ' 填充数据 Dim cell As Range For Each cell In rng ListBox1.AddItem cell.Value Next cell End Sub ' 从窗体获取数据 Private Sub GetFormData() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("结果") ' 获取文本框值 ws.Range("A1").Value = TextBox1.Text ' 获取组合框选择 ws.Range("A2").Value = ComboBox1.Value ' 获取复选框状态 ws.Range("A3").Value = IIf(CheckBox1.Value, "是", "否") ' 获取单选按钮选择 Dim selectedOption As String If OptionButton1.Value Then selectedOption = "选项1" If OptionButton2.Value Then selectedOption = "选项2" ws.Range("A4").Value = selectedOption ' 获取多页控件当前页 ws.Range("A5").Value = "页" & (MultiPage1.Value + 1) End Sub ' 绑定数据到窗体 Private Sub BindDataToForm() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("数据") ' 设置文本框值 TextBox1.Text = ws.Range("B2").Value ' 设置组合框选择 ComboBox1.Value = ws.Range("B3").Value ' 设置复选框状态 CheckBox1.Value = (ws.Range("B4").Value = "是") ' 设置单选按钮 Select Case ws.Range("B5").Value Case "选项1": OptionButton1.Value = True Case "选项2": OptionButton2.Value = True End Select End Sub

' 注册自定义控件(需要先引用) ' 工具 -> 引用 -> 选择 Microsoft Windows Common Controls 6.0 (SP6) ' 使用TreeView控件 Private Sub InitializeTreeView() ' 添加节点 Dim nod As MSComctlLib.Node Set nod = TreeView1.Nodes.Add(, , "root", "根节点") ' 添加子节点 TreeView1.Nodes.Add "root", tvwChild, "child1", "子节点1" TreeView1.Nodes.Add "root", tvwChild, "child2", "子节点2" ' 展开节点 TreeView1.Nodes("root").Expanded = True End Sub ' 使用ListView控件 Private Sub InitializeListView() ' 设置列 With ListView1 .View = lvwReport .ColumnHeaders.Add , , "姓名", 80 .ColumnHeaders.Add , , "年龄", 50 .ColumnHeaders.Add , , "部门", 100 End With ' 添加项目 Dim itm As MSComctlLib.ListItem Set itm = ListView1.ListItems.Add(, , "张三") itm.SubItems(1) = "28" itm.SubItems(2) = "销售部" Set itm = ListView1.ListItems.Add(, , "李四") itm.SubItems(1) = "32" itm.SubItems(2) = "技术部" End Sub ' 使用StatusBar控件 Private Sub UpdateStatusBar() StatusBar1.Panels(1).Text = "就绪" StatusBar1.Panels(2).Text = Format(Now(), "yyyy-mm-dd hh:mm:ss") StatusBar1.Panels(3).Text = "记录数: " & ListView1.ListItems.Count End Sub

Sub BasicFileOperations() Dim filePath As String filePath = "C:\Temp\test.txt" ' 1. 检查文件是否存在 If Dir(filePath) <> "" Then Debug.Print "文件已存在" Else Debug.Print "文件不存在" End If ' 2. 创建文件并写入内容 Dim fileNum As Integer fileNum = FreeFile ' 获取可用文件号 Open filePath For Output As #fileNum Print #fileNum, "第一行内容" Print #fileNum, "第二行内容" Close #fileNum ' 3. 追加内容到文件 Open filePath For Append As #fileNum Print #fileNum, "追加的内容" Close #fileNum ' 4. 读取文件内容 Dim fileContent As String Dim lineContent As String Open filePath For Input As #fileNum Do Until EOF(fileNum) Line Input #fileNum, lineContent fileContent = fileContent & lineContent & vbCrLf Loop Close #fileNum Debug.Print "文件内容:" & vbCrLf & fileContent ' 5. 删除文件 Kill filePath Debug.Print "文件已删除" End Sub

Sub FileFolderManagement() Dim folderPath As String folderPath = "C:\Temp\VBA_Files" ' 1. 创建文件夹 If Dir(folderPath, vbDirectory) = "" Then MkDir folderPath Debug.Print "文件夹已创建: " & folderPath End If ' 2. 创建多个文件 Dim i As Integer For i = 1 To 5 Dim filePath As String filePath = folderPath & "\file" & i & ".txt" Dim fileNum As Integer fileNum = FreeFile Open filePath For Output As #fileNum Print #fileNum, "这是文件" & i & "的内容" Close #fileNum Next i ' 3. 列出文件夹中的文件 Debug.Print "文件夹内容:" Dim fileName As String fileName = Dir(folderPath & "\*.*") Do While fileName <> "" Debug.Print fileName fileName = Dir() Loop ' 4. 复制文件 FileCopy folderPath & "\file1.txt", folderPath & "\file1_copy.txt" Debug.Print "文件已复制" ' 5. 重命名文件 Name folderPath & "\file2.txt" As folderPath & "\file2_renamed.txt" Debug.Print "文件已重命名" ' 6. 获取文件信息 Debug.Print "文件1大小: " & FileLen(folderPath & "\file1.txt") & "字节" Debug.Print "文件1创建时间: " & FileDateTime(folderPath & "\file1.txt") ' 7. 删除多个文件 For i = 1 To 5 On Error Resume Next ' 跳过不存在的文件 Kill folderPath & "\file" & i & ".txt" Kill folderPath & "\file" & i & "_renamed.txt" Kill folderPath & "\file" & i & "_copy.txt" On Error GoTo 0 Next i ' 8. 删除文件夹 RmDir folderPath Debug.Print "文件夹已删除" End Sub

Sub FileDialogs() ' 1. 文件打开对话框 Dim selectedFile As Variant selectedFile = Application.GetOpenFilename( _ Title:="选择文件", _ FileFilter:="文本文件 (*.txt),*.txt,所有文件 (*.*),*.*") If selectedFile <> False Then Debug.Print "选择的文件: " & selectedFile Else Debug.Print "用户取消了选择" End If ' 2. 文件保存对话框 Dim saveFile As Variant saveFile = Application.GetSaveAsFilename( _ InitialFileName:="默认文件名.txt", _ FileFilter:="文本文件 (*.txt),*.txt", _ Title:="保存文件") If saveFile <> False Then Debug.Print "保存到: " & saveFile ' 实际保存操作 Dim fileNum As Integer fileNum = FreeFile Open saveFile For Output As #fileNum Print #fileNum, "这是保存的文件内容" Close #fileNum End If ' 3. 文件夹选择对话框 Dim shellApp As Object Set shellApp = CreateObject("Shell.Application") Dim selectedFolder As Object Set selectedFolder = shellApp.BrowseForFolder(0, "选择文件夹", 0) If Not selectedFolder Is Nothing Then Debug.Print "选择的文件夹: " & selectedFolder.Self.Path ' 在选择的文件夹中创建文件 Dim newFilePath As String newFilePath = selectedFolder.Self.Path & "\新文件.txt" fileNum = FreeFile Open newFilePath For Output As #fileNum Print #fileNum, "在新文件夹中创建的文件" Close #fileNum End If End Sub

Sub BinaryFileOperations() Dim filePath As String filePath = "C:\Temp\binary.dat" ' 1. 写入二进制文件 Dim fileNum As Integer fileNum = FreeFile Open filePath For Binary As #fileNum Dim intValue As Integer: intValue = 12345 Put #fileNum, , intValue Dim dblValue As Double: dblValue = 3.1415926 Put #fileNum, , dblValue Dim strValue As String: strValue = "二进制字符串" Put #fileNum, , strValue Close #fileNum ' 2. 读取二进制文件 Dim readInt As Integer Dim readDbl As Double Dim readStr As String * 20 ' 固定长度字符串 Open filePath For Binary As #fileNum Get #fileNum, , readInt Get #fileNum, , readDbl Get #fileNum, , readStr Close #fileNum Debug.Print "读取的整数: " & readInt Debug.Print "读取的浮点数: " & readDbl Debug.Print "读取的字符串: " & readStr ' 3. 修改二进制文件 Dim newInt As Integer: newInt = 54321 Open filePath For Binary As #fileNum Put #fileNum, 1, newInt ' 在位置1写入新整数 Close #fileNum ' 验证修改 Open filePath For Binary As #fileNum Get #fileNum, , readInt Close #fileNum Debug.Print "修改后的整数: " & readInt ' 删除文件 Kill filePath End Sub

Sub FileSystemObjectExample() ' 创建FileSystemObject Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") ' 1. 文件和文件夹操作 Dim folderPath As String folderPath = "C:\Temp\FSO_Demo" ' 检查并创建文件夹 If Not fso.FolderExists(folderPath) Then fso.CreateFolder folderPath Debug.Print "文件夹已创建: " & folderPath End If ' 创建文本文件 Dim filePath As String filePath = folderPath & "\fso_test.txt" Dim textFile As Object Set textFile = fso.CreateTextFile(filePath, True) ' True表示覆盖现有文件 textFile.WriteLine "这是使用FSO创建的文件" textFile.WriteLine "第二行内容" textFile.Close ' 2. 读取文件 Set textFile = fso.OpenTextFile(filePath, 1) ' 1表示只读 Debug.Print "文件内容:" Do Until textFile.AtEndOfStream Debug.Print textFile.ReadLine Loop textFile.Close ' 3. 文件信息 Dim file As Object Set file = fso.GetFile(filePath) Debug.Print "文件名: " & file.Name Debug.Print "路径: " & file.Path Debug.Print "大小: " & file.Size & "字节" Debug.Print "创建时间: " & file.DateCreated Debug.Print "修改时间: " & file.DateLastModified ' 4. 文件夹内容枚举 Dim folder As Object Set folder = fso.GetFolder(folderPath) Debug.Print "文件夹内容:" Dim subFile As Object For Each subFile In folder.Files Debug.Print "文件: " & subFile.Name Next ' 5. 复制和删除 Dim newFilePath As String newFilePath = folderPath & "\fso_test_copy.txt" fso.CopyFile filePath, newFilePath Debug.Print "文件已复制" fso.DeleteFile filePath Debug.Print "原文件已删除" ' 删除文件夹 fso.DeleteFolder folderPath Debug.Print "文件夹已删除" End Sub

Sub BasicStringOperations() ' 1. 字符串声明和连接 Dim str1 As String: str1 = "Hello" Dim str2 As String: str2 = "VBA" Dim combinedStr As String combinedStr = str1 & " " & str2 ' 使用 & 连接字符串 Debug.Print combinedStr ' 输出: Hello VBA ' 2. 字符串长度 Dim strLength As Integer strLength = Len(combinedStr) Debug.Print "字符串长度: " & strLength ' 输出: 9 ' 3. 大小写转换 Debug.Print UCase(combinedStr) ' 输出: HELLO VBA Debug.Print LCase(combinedStr) ' 输出: hello vba ' 4. 去除空格 Dim spacedStr As String: spacedStr = " 前后有空格 " Debug.Print "原始字符串: '" & spacedStr & "'" Debug.Print "去除前导空格: '" & LTrim(spacedStr) & "'" Debug.Print "去除尾部空格: '" & RTrim(spacedStr) & "'" Debug.Print "去除所有空格: '" & Trim(spacedStr) & "'" ' 5. 字符串比较 Dim compareResult As Integer compareResult = StrComp("apple", "Apple", vbTextCompare) ' 不区分大小写 Debug.Print "比较结果(不区分大小写): " & compareResult ' 输出: 0 (相等) compareResult = StrComp("apple", "Apple", vbBinaryCompare) ' 区分大小写 Debug.Print "比较结果(区分大小写): " & compareResult ' 输出: 1 (大于) ' 6. 字符串重复 Dim repeatedStr As String repeatedStr = String(5, "*") Debug.Print repeatedStr ' 输出: ***** ' 7. 空格字符串 Dim spaceStr As String spaceStr = Space(10) Debug.Print "10个空格: '" & spaceStr & "'" End Sub

Sub StringManipulation() Dim mainStr As String: mainStr = "Visual Basic for Applications" ' 1. 截取子字符串 Debug.Print "左3字符: " & Left(mainStr, 3) ' 输出: Vis Debug.Print "右5字符: " & Right(mainStr, 5) ' 输出: tions Debug.Print "中间部分: " & Mid(mainStr, 8, 5) ' 输出: Basic ' 2. 查找子字符串 Dim pos As Integer pos = InStr(mainStr, "Basic") Debug.Print "'Basic'的位置: " & pos ' 输出: 8 pos = InStr(9, mainStr, "a") ' 从第9个字符开始查找 Debug.Print "从第9字符开始查找'a': " & pos ' 输出: 10 ' 3. 反向查找 pos = InStrRev(mainStr, "a") Debug.Print "最后一个'a'的位置: " & pos ' 输出: 22 ' 4. 替换字符串 Dim replacedStr As String replacedStr = Replace(mainStr, "Applications", "Apps") Debug.Print "替换后: " & replacedStr ' 输出: Visual Basic for Apps ' 5. 分割字符串 Dim words() As String words = Split(mainStr, " ") Debug.Print "分割结果:" Dim i As Integer For i = LBound(words) To UBound(words) Debug.Print "单词" & i + 1 & ": " & words(i) Next i ' 6. 连接字符串数组 Dim joinedStr As String joinedStr = Join(words, "-") Debug.Print "连接后: " & joinedStr ' 输出: Visual-Basic-for-Applications End Sub

Sub StringFormatting() ' 1. 格式化数字 Dim num As Double: num = 1234.5678 Debug.Print "原始数字: " & num Debug.Print "格式化(两位小数): " & Format(num, "0.00") ' 1234.57 Debug.Print "格式化(千位分隔): " & Format(num, "#,##0.00") ' 1,234.57 Debug.Print "格式化(货币): " & Format(num, "Currency") ' ¥1,234.57 Debug.Print "格式化(百分比): " & Format(0.456, "Percent") ' 45.60% ' 2. 格式化日期时间 Dim dt As Date: dt = Now() Debug.Print "原始日期: " & dt Debug.Print "短日期格式: " & Format(dt, "Short Date") ' 2023/5/15 Debug.Print "长日期格式: " & Format(dt, "Long Date") ' 2023年5月15日 Debug.Print "自定义日期: " & Format(dt, "yyyy-mm-dd") ' 2023-05-15 Debug.Print "时间格式: " & Format(dt, "hh:mm:ss") ' 14:30:45 Debug.Print "完整格式: " & Format(dt, "yyyy-mm-dd hh:mm:ss") ' 2023-05-15 14:30:45 ' 3. 格式化字符串 Dim str As String: str = "hello" Debug.Print "首字母大写: " & StrConv(str, vbProperCase) ' Hello Debug.Print "全部大写: " & StrConv(str, vbUpperCase) ' HELLO Debug.Print "全部小写: " & StrConv(str, vbLowerCase) ' hello ' 4. 自定义格式化 Dim value As Variant: value = 123 Debug.Print "前导零: " & Format(value, "00000") ' 00123 Debug.Print "科学计数: " & Format(123456789, "Scientific") ' 1.23E+08 ' 5. 格式化布尔值 Dim boolVal As Boolean: boolVal = True Debug.Print "布尔值: " & Format(boolVal, "Yes/No") ' Yes Debug.Print "布尔值: " & Format(boolVal, "True/False") ' True Debug.Print "布尔值: " & Format(boolVal, "On/Off") ' On End Sub

Sub StringEncoding() ' 1. ASCII码与字符转换 Dim asciiCode As Integer: asciiCode = 65 Debug.Print "ASCII码 " & asciiCode & " 对应的字符: " & Chr(asciiCode) ' A Dim char As String: char = "B" Debug.Print "字符 '" & char & "' 的ASCII码: " & Asc(char) ' 66 ' 2. Unicode字符 Dim unicodeChar As String: unicodeChar = "中" Debug.Print "字符 '" & unicodeChar & "' 的代码: " & AscW(unicodeChar) ' 20013 Debug.Print "代码 20013 对应的字符: " & ChrW(20013) ' 中 ' 3. 字节数组与字符串转换 Dim byteArray() As Byte Dim text As String: text = "VBA编程" ' 字符串转字节数组(Unicode) byteArray = text Debug.Print "字节数组长度: " & UBound(byteArray) - LBound(byteArray) + 1 ' 字节数组转字符串 Dim newText As String newText = byteArray Debug.Print "转换回字符串: " & newText ' 4. ANSI与Unicode转换 ' 需要使用Windows API进行更复杂的编码转换 ' 以下是声明示例: ' Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" _ ' (ByVal CodePage As Long, ByVal dwFlags As Long, _ ' ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, _ ' ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long End Sub

Sub RegularExpressions() ' 需要引用 "Microsoft VBScript Regular Expressions 5.5" Dim regEx As Object Set regEx = CreateObject("VBScript.RegExp") ' 1. 简单匹配 Dim text As String: text = "我的电话是123-4567-8910，另一个是987-6543-2100" With regEx .Pattern = "\d{3}-\d{4}-\d{4}" ' 匹配电话号码模式 .Global = True ' 查找所有匹配 Dim matches As Object Set matches = .Execute(text) Debug.Print "找到的电话号码:" Dim match As Object For Each match In matches Debug.Print match.Value Next End With ' 2. 替换 Dim replacedText As String regEx.Pattern = "\d{3}-\d{4}-\d{4}" replacedText = regEx.Replace(text, "[电话号码]") Debug.Print "替换后文本: " & replacedText ' 3. 测试匹配 Dim testStr As String: testStr = "example@domain.com" regEx.Pattern = "^[\w-\.]+@([\w-]+\.)+[\w-]{2,4}$" ' 简单邮箱正则 If regEx.Test(testStr) Then Debug.Print testStr & " 是有效的邮箱地址" Else Debug.Print testStr & " 不是有效的邮箱地址" End If ' 4. 分组捕获 Dim htmlText As String: htmlText = "链接" regEx.Pattern = "(.+?)" Set matches = regEx.Execute(htmlText) If matches.Count > 0 Then Debug.Print "链接URL: " & matches(0).SubMatches(0) Debug.Print "链接文本: " & matches(0).SubMatches(1) End If ' 5. 复杂模式 Dim complexText As String: complexText = "日期: 2023-05-15, 时间: 14:30" regEx.Pattern = "日期: (\d{4}-\d{2}-\d{2}), 时间: (\d{2}:\d{2})" Set matches = regEx.Execute(complexText) If matches.Count > 0 Then Debug.Print "匹配的日期: " & matches(0).SubMatches(0) Debug.Print "匹配的时间: " & matches(0).SubMatches(1) End If End Sub

Sub ArrayBasics() ' 1. 声明数组 Dim arr1(5) As Integer ' 索引0到5 Dim arr2(1 To 6) As String ' 索引1到6 Dim dynamicArr() As Double ' 动态数组 ' 2. 初始化数组 arr1(0) = 10: arr1(1) = 20: arr1(2) = 30 arr1(3) = 40: arr1(4) = 50: arr1(5) = 60 arr2(1) = "一": arr2(2) = "二": arr2(3) = "三" arr2(4) = "四": arr2(5) = "五": arr2(6) = "六" ' 3. 动态数组 ReDim dynamicArr(1 To 3) dynamicArr(1) = 1.1: dynamicArr(2) = 2.2: dynamicArr(3) = 3.3 ' 4. 访问数组元素 Debug.Print "arr1(2): " & arr1(2) ' 30 Debug.Print "arr2(4): " & arr2(4) ' 四 Debug.Print "dynamicArr(3): " & dynamicArr(3) ' 3.3 ' 5. 数组大小 Debug.Print "arr1 上界: " & UBound(arr1) ' 5 Debug.Print "arr1 下界: " & LBound(arr1) ' 0 Debug.Print "arr2 上界: " & UBound(arr2) ' 6 Debug.Print "arr2 下界: " & LBound(arr2) ' 1 ' 6. 遍历数组 Debug.Print "arr1 内容:" Dim i As Integer For i = LBound(arr1) To UBound(arr1) Debug.Print "arr1(" & i & "): " & arr1(i) Next i ' 7. 数组函数 Debug.Print "arr1 第一个元素: " & arr1(LBound(arr1)) Debug.Print "arr1 最后一个元素: " & arr1(UBound(arr1)) End Sub

Sub MultiDimensionalArrays() ' 1. 声明多维数组 Dim matrix(1 To 3, 1 To 3) As Integer ' 3x3矩阵 Dim cube(1 To 2, 1 To 2, 1 To 2) As String ' 2x2x2立方体 ' 2. 初始化多维数组 matrix(1, 1) = 1: matrix(1, 2) = 2: matrix(1, 3) = 3 matrix(2, 1) = 4: matrix(2, 2) = 5: matrix(2, 3) = 6 matrix(3, 1) = 7: matrix(3, 2) = 8: matrix(3, 3) = 9 cube(1, 1, 1) = "A": cube(1, 1, 2) = "B" cube(1, 2, 1) = "C": cube(1, 2, 2) = "D" cube(2, 1, 1) = "E": cube(2, 1, 2) = "F" cube(2, 2, 1) = "G": cube(2, 2, 2) = "H" ' 3. 访问多维数组 Debug.Print "matrix(2,3): " & matrix(2, 3) ' 6 Debug.Print "cube(2,1,2): " & cube(2, 1, 2) ' F ' 4. 遍历多维数组 Debug.Print "matrix 内容:" Dim i As Integer, j As Integer For i = LBound(matrix, 1) To UBound(matrix, 1) For j = LBound(matrix, 2) To UBound(matrix, 2) Debug.Print "matrix(" & i & "," & j & "): " & matrix(i, j) Next j Next i ' 5. 动态多维数组 Dim dynamicMatrix() As Double ReDim dynamicMatrix(1 To 2, 1 To 2) dynamicMatrix(1, 1) = 1.1: dynamicMatrix(1, 2) = 1.2 dynamicMatrix(2, 1) = 2.1: dynamicMatrix(2, 2) = 2.2 ' 6. 获取维度信息 Debug.Print "matrix 维度数: " & GetArrayDimensions(matrix) Debug.Print "matrix 第一维大小: " & (UBound(matrix, 1) - LBound(matrix, 1) + 1) Debug.Print "matrix 第二维大小: " & (UBound(matrix, 2) - LBound(matrix, 2) + 1) End Sub ' 获取数组维度数的函数 Function GetArrayDimensions(arr As Variant) As Integer On Error GoTo Finalize Dim dimCount As Integer dimCount = 0 Do dimCount = dimCount + 1 ' 尝试访问更高维度 Dim temp As Long temp = UBound(arr, dimCount + 1) Loop Finalize: GetArrayDimensions = dimCount End Function

Sub DynamicArrayOperations() ' 1. 声明动态数组 Dim dynArr() As String ' 2. 初始分配大小 ReDim dynArr(1 To 3) dynArr(1) = "第一项": dynArr(2) = "第二项": dynArr(3) = "第三项" ' 3. 保留数据重新分配大小 ReDim Preserve dynArr(1 To 5) dynArr(4) = "第四项": dynArr(5) = "第五项" Debug.Print "重新分配后的数组:" Dim i As Integer For i = LBound(dynArr) To UBound(dynArr) Debug.Print dynArr(i) Next i ' 4. 只能调整最后一维 Dim multiArr(1 To 2, 1 To 3) As Integer ' ReDim Preserve multiArr(1 To 2, 1 To 4) ' 可以 ' ReDim Preserve multiArr(1 To 3, 1 To 3) ' 运行时错误 ' 5. 数组清空 Erase dynArr Debug.Print "数组大小: " & IIf(IsArrayAllocated(dynArr), UBound(dynArr), "未分配") ' 6. 从范围填充数组 Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(1) Dim rangeArr As Variant rangeArr = ws.Range("A1:C3").Value ' 二维数组 Debug.Print "从范围填充的数组:" For i = LBound(rangeArr, 1) To UBound(rangeArr, 1) For j = LBound(rangeArr, 2) To UBound(rangeArr, 2) Debug.Print "rangeArr(" & i & "," & j & "): " & rangeArr(i, j) Next j Next i ' 7. 数组转置 Dim transposedArr As Variant transposedArr = Application.Transpose(rangeArr) Debug.Print "转置后的数组:" For i = LBound(transposedArr, 1) To UBound(transposedArr, 1) For j = LBound(transposedArr, 2) To UBound(transposedArr, 2) Debug.Print "transposedArr(" & i & "," & j & "): " & transposedArr(i, j) Next j Next i End Sub ' 检查数组是否已分配的函数 Function IsArrayAllocated(arr As Variant) As Boolean On Error Resume Next IsArrayAllocated = IsArray(arr) And _ Not IsError(LBound(arr, 1)) And _ LBound(arr, 1) <= UBound(arr, 1) End Function

Sub ArrayFunctions() ' 1. Array函数 - 创建并初始化数组 Dim days() As Variant days = Array("日", "月", "火", "水", "木", "金", "土") Debug.Print "星期数组:" Dim i As Integer For i = LBound(days) To UBound(days) Debug.Print days(i) Next i ' 2. Split函数 - 字符串分割为数组 Dim csvStr As String: csvStr = "苹果,香蕉,橙子,葡萄" Dim fruits() As String fruits = Split(csvStr, ",") Debug.Print "水果数组:" For i = LBound(fruits) To UBound(fruits) Debug.Print fruits(i) Next i ' 3. Join函数 - 数组合并为字符串 Dim joinedStr As String joinedStr = Join(fruits, ";") Debug.Print "合并后的字符串: " & joinedStr ' 4. Filter函数 - 过滤数组 Dim filteredFruits() As String filteredFruits = Filter(fruits, "果", True, vbTextCompare) Debug.Print "包含'果'的水果:" For i = LBound(filteredFruits) To UBound(filteredFruits) Debug.Print filteredFruits(i) Next i ' 5. 数组排序(自定义实现) Dim numbers() As Integer numbers = Array(5, 2, 8, 1, 9, 3) Call BubbleSort(numbers) Debug.Print "排序后的数组:" For i = LBound(numbers) To UBound(numbers) Debug.Print numbers(i) Next i ' 6. 查找数组元素 Dim searchResult As Integer searchResult = ArraySearch(numbers, 8) Debug.Print "数字8的位置: " & searchResult ' 7. 数组最大/最小值 Debug.Print "最大值: " & ArrayMax(numbers) Debug.Print "最小值: " & ArrayMin(numbers) End Sub ' 冒泡排序算法 Sub BubbleSort(arr() As Integer) Dim i As Integer, j As Integer Dim temp As Integer For i = LBound(arr) To UBound(arr) - 1 For j = i + 1 To UBound(arr) If arr(i) > arr(j) Then temp = arr(i) arr(i) = arr(j) arr(j) = temp End If Next j Next i End Sub ' 查找数组元素 Function ArraySearch(arr() As Integer, value As Integer) As Integer Dim i As Integer For i = LBound(arr) To UBound(arr) If arr(i) = value Then ArraySearch = i Exit Function End If Next i ArraySearch = -1 ' 未找到 End Function ' 查找数组最大值 Function ArrayMax(arr() As Integer) As Integer Dim i As Integer ArrayMax = arr(LBound(arr)) For i = LBound(arr) + 1 To UBound(arr) If arr(i) > ArrayMax Then ArrayMax = arr(i) Next i End Function ' 查找数组最小值 Function ArrayMin(arr() As Integer) As Integer Dim i As Integer ArrayMin = arr(LBound(arr)) For i = LBound(arr) + 1 To UBound(arr) If arr(i) < ArrayMin Then ArrayMin = arr(i) Next i End Function

Sub AdvancedArrayTechniques() ' 1. 数组的数组(锯齿数组) Dim jaggedArray() As Variant ReDim jaggedArray(1 To 3) jaggedArray(1) = Array(1, 2, 3) jaggedArray(2) = Array("A", "B", "C", "D") jaggedArray(3) = Array(True, False, True) Debug.Print "锯齿数组内容:" Dim i As Integer, j As Integer For i = LBound(jaggedArray) To UBound(jaggedArray) For j = LBound(jaggedArray(i)) To UBound(jaggedArray(i)) Debug.Print "jaggedArray(" & i & ")(" & j & "): " & jaggedArray(i)(j) Next j Next i ' 2. 数组作为函数参数和返回值 Dim sourceArr() As Integer: sourceArr = Array(1, 2, 3, 4, 5) Dim squaredArr() As Integer squaredArr = SquareArray(sourceArr) Debug.Print "平方后的数组:" For i = LBound(squaredArr) To UBound(squaredArr) Debug.Print squaredArr(i) Next i ' 3. 数组拷贝 Dim copiedArr() As Integer copiedArr = CopyArray(sourceArr) ' 修改原数组不影响拷贝 sourceArr(1) = 100 Debug.Print "原数组第一个元素: " & sourceArr(1) Debug.Print "拷贝数组第一个元素: " & copiedArr(1) ' 4. 二维数组排序 Dim dataArr(1 To 5, 1 To 2) As Variant dataArr(1, 1) = "张三": dataArr(1, 2) = 85 dataArr(2, 1) = "李四": dataArr(2, 2) = 92 dataArr(3, 1) = "王五": dataArr(3, 2) = 78 dataArr(4, 1) = "赵六": dataArr(4, 2) = 95 dataArr(5, 1) = "钱七": dataArr(5, 2) = 88 ' 按分数降序排序 Call Sort2DArray(dataArr, 2, False) Debug.Print "按分数排序后的数据:" For i = LBound(dataArr, 1) To UBound(dataArr, 1) Debug.Print dataArr(i, 1) & ": " & dataArr(i, 2) Next i ' 5. 数组与集合转换 Dim coll As Collection Set coll = ArrayToCollection(sourceArr) Debug.Print "集合中的元素:" For i = 1 To coll.Count Debug.Print coll(i) Next i ' 6. 数组去重 Dim dupArr() As Variant: dupArr = Array(1, 2, 2, 3, 4, 4, 4, 5) Dim uniqueArr() As Variant uniqueArr = RemoveDuplicates(dupArr) Debug.Print "去重后的数组:" For i = LBound(uniqueArr) To UBound(uniqueArr) Debug.Print uniqueArr(i) Next i End Sub ' 数组平方函数 Function SquareArray(arr() As Integer) As Integer() Dim result() As Integer ReDim result(LBound(arr) To UBound(arr)) Dim i As Integer For i = LBound(arr) To UBound(arr) result(i) = arr(i) * arr(i) Next i SquareArray = result End Function ' 数组拷贝函数 Function CopyArray(arr() As Integer) As Integer() Dim result() As Integer ReDim result(LBound(arr) To UBound(arr)) Dim i As Integer For i = LBound(arr) To UBound(arr) result(i) = arr(i) Next i CopyArray = result End Function ' 二维数组排序 Sub Sort2DArray(arr() As Variant, sortCol As Integer, ascending As Boolean) Dim i As Long, j As Long Dim tempRow() As Variant ReDim tempRow(LBound(arr, 2) To UBound(arr, 2)) For i = LBound(arr, 1) To UBound(arr, 1) - 1 For j = i + 1 To UBound(arr, 1) ' 根据排序方向比较 Dim shouldSwap As Boolean If ascending Then shouldSwap = arr(i, sortCol) > arr(j, sortCol) Else shouldSwap = arr(i, sortCol) < arr(j, sortCol) End If If shouldSwap Then ' 交换整行数据 Dim col As Integer For col = LBound(arr, 2) To UBound(arr, 2) tempRow(col) = arr(i, col) arr(i, col) = arr(j, col) arr(j, col) = tempRow(col) Next col End If Next j Next i End Sub ' 数组转集合 Function ArrayToCollection(arr() As Integer) As Collection Dim coll As New Collection Dim i As Integer For i = LBound(arr) To UBound(arr) coll.Add arr(i) Next i Set ArrayToCollection = coll End Function ' 数组去重 Function RemoveDuplicates(arr() As Variant) As Variant() Dim coll As New Collection Dim i As Integer On Error Resume Next For i = LBound(arr) To UBound(arr) coll.Add arr(i), CStr(arr(i)) Next i On Error GoTo 0 Dim result() As Variant ReDim result(1 To coll.Count) For i = 1 To coll.Count result(i) = coll(i) Next i RemoveDuplicates = result End Function

Sub ADOBasics() ' 需要引用 Microsoft ActiveX Data Objects x.x Library Dim conn As ADODB.Connection Dim rs As ADODB.Recordset Dim sql As String ' 1. 创建连接 Set conn = New ADODB.Connection ' 2. 连接字符串(根据数据库类型不同) ' Access连接字符串 Dim dbPath As String dbPath = ThisWorkbook.Path & "\sample.accdb" conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & dbPath ' SQL Server连接字符串示例 ' conn.ConnectionString = "Provider=SQLOLEDB;Data Source=服务器名;" & _ ' "Initial Catalog=数据库名;User ID=用户名;Password=密码;" ' 3. 打开连接 conn.Open ' 4. 创建记录集 Set rs = New ADODB.Recordset ' 5. 执行SQL查询 sql = "SELECT * FROM Customers" rs.Open sql, conn, adOpenStatic, adLockReadOnly ' 6. 处理结果 Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(1) ws.Cells.Clear ' 写入表头 Dim i As Integer For i = 0 To rs.Fields.Count - 1 ws.Cells(1, i + 1).Value = rs.Fields(i).Name Next i ' 写入数据 ws.Range("A2").CopyFromRecordset rs ' 7. 关闭连接 rs.Close conn.Close ' 8. 释放对象 Set rs = Nothing Set conn = Nothing MsgBox "数据导入完成", vbInformation End Sub

Sub DataQuery() Dim conn As ADODB.Connection Dim rs As ADODB.Recordset Dim sql As String Set conn = New ADODB.Connection conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _ ThisWorkbook.Path & "\sample.accdb" conn.Open ' 1. 基本查询 sql = "SELECT CustomerID, CompanyName, ContactName FROM Customers" Set rs = conn.Execute(sql) Debug.Print "基本查询结果:" Do Until rs.EOF Debug.Print rs("CustomerID") & ", " & rs("CompanyName") & ", " & rs("ContactName") rs.MoveNext Loop rs.Close ' 2. 带条件查询 sql = "SELECT * FROM Orders WHERE OrderDate BETWEEN #2023-01-01# AND #2023-12-31#" Set rs = conn.Execute(sql) Debug.Print "2023年订单: " & rs.RecordCount & "条" rs.Close ' 3. 参数化查询(防止SQL注入) Dim paramQuery As ADODB.Command Set paramQuery = New ADODB.Command paramQuery.ActiveConnection = conn paramQuery.CommandText = "SELECT * FROM Products WHERE CategoryID = ? AND UnitPrice > ?" ' 添加参数 Dim categoryParam As ADODB.Parameter Dim priceParam As ADODB.Parameter Set categoryParam = paramQuery.CreateParameter("CategoryID", adInteger, adParamInput) Set priceParam = paramQuery.CreateParameter("UnitPrice", adCurrency, adParamInput) categoryParam.Value = 1 ' 饮料类别 priceParam.Value = 20 ' 价格大于20 paramQuery.Parameters.Append categoryParam paramQuery.Parameters.Append priceParam Set rs = paramQuery.Execute Debug.Print "饮料类高价产品:" Do Until rs.EOF Debug.Print rs("ProductName") & ": " & rs("UnitPrice") rs.MoveNext Loop rs.Close ' 4. 连接查询 sql = "SELECT o.OrderID, c.CompanyName, o.OrderDate " & _ "FROM Orders o INNER JOIN Customers c ON o.CustomerID = c.CustomerID " & _ "WHERE o.OrderDate > #2023-06-01#" Set rs = conn.Execute(sql) Debug.Print "连接查询结果:" Do Until rs.EOF Debug.Print rs("OrderID") & ", " & rs("CompanyName") & ", " & rs("OrderDate") rs.MoveNext Loop rs.Close ' 5. 聚合查询 sql = "SELECT CategoryID, COUNT(*) AS ProductCount, AVG(UnitPrice) AS AvgPrice " & _ "FROM Products GROUP BY CategoryID" Set rs = conn.Execute(sql) Debug.Print "分类统计:" Do Until rs.EOF Debug.Print "分类" & rs("CategoryID") & ": " & rs("ProductCount") & _ "产品, 均价" & rs("AvgPrice") rs.MoveNext Loop ' 清理 rs.Close conn.Close Set rs = Nothing Set conn = Nothing End Sub

Sub DataManipulation() Dim conn As ADODB.Connection Dim rs As ADODB.Recordset Dim sql As String Set conn = New ADODB.Connection conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _ ThisWorkbook.Path & "\sample.accdb" conn.Open ' 1. 插入数据 sql = "INSERT INTO Customers (CustomerID, CompanyName, ContactName) " & _ "VALUES ('TEST1', '测试公司', '测试联系人')" conn.Execute sql Debug.Print "插入数据完成" ' 2. 更新数据 sql = "UPDATE Customers SET ContactTitle = '销售经理' " & _ "WHERE CustomerID = 'TEST1'" conn.Execute sql Debug.Print "更新数据完成" ' 3. 删除数据 sql = "DELETE FROM Customers WHERE CustomerID = 'TEST1'" conn.Execute sql Debug.Print "删除数据完成" ' 4. 事务处理 On Error GoTo ErrorHandler conn.BeginTrans ' 开始事务 sql = "INSERT INTO Customers (CustomerID, CompanyName) VALUES ('TEMP1', '临时公司1')" conn.Execute sql sql = "INSERT INTO Customers (CustomerID, CompanyName) VALUES ('TEMP2', '临时公司2')" conn.Execute sql ' 模拟错误 ' Dim x As Integer: x = 1 / 0 conn.CommitTrans ' 提交事务 Debug.Print "事务处理完成" ' 5. 使用记录集更新数据 Set rs = New ADODB.Recordset rs.Open "SELECT * FROM Customers WHERE CustomerID LIKE 'TEMP%'", _ conn, adOpenDynamic, adLockOptimistic Do Until rs.EOF rs("ContactName") = "临时联系人" rs.Update rs.MoveNext Loop rs.Close ' 6. 批量删除 rs.Open "SELECT * FROM Customers WHERE CustomerID LIKE 'TEMP%'", _ conn, adOpenDynamic, adLockOptimistic Do Until rs.EOF rs.Delete rs.MoveNext Loop rs.Close conn.Close Set rs = Nothing Set conn = Nothing Exit Sub ErrorHandler: conn.RollbackTrans ' 回滚事务 Debug.Print "发生错误，事务已回滚" conn.Close Set conn = Nothing End Sub

Sub ConnectToDifferentDBs() ' 1. 连接Excel文件作为数据库 Dim excelConn As ADODB.Connection Set excelConn = New ADODB.Connection Dim excelPath As String excelPath = ThisWorkbook.Path & "\data.xlsx" excelConn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _ "Data Source=" & excelPath & ";" & _ "Extended Properties=""Excel 12.0 Xml;HDR=YES"";" excelConn.Open Dim rsExcel As ADODB.Recordset Set rsExcel = New ADODB.Recordset rsExcel.Open "SELECT * FROM [Sheet1$]", excelConn Debug.Print "Excel数据:" Do Until rsExcel.EOF Debug.Print rsExcel(0) & ", " & rsExcel(1) rsExcel.MoveNext Loop rsExcel.Close excelConn.Close ' 2. 连接SQLite数据库 Dim sqliteConn As ADODB.Connection Set sqliteConn = New ADODB.Connection Dim sqlitePath As String sqlitePath = ThisWorkbook.Path & "\sample.db" ' 需要先安装SQLite ODBC驱动 sqliteConn.ConnectionString = "Driver=SQLite3 ODBC Driver;" & _ "Database=" & sqlitePath & ";" On Error Resume Next sqliteConn.Open If sqliteConn.State = adStateOpen Then Debug.Print "成功连接SQLite数据库" Dim rsSQLite As ADODB.Recordset Set rsSQLite = New ADODB.Recordset rsSQLite.Open "SELECT * FROM users", sqliteConn Do Until rsSQLite.EOF Debug.Print rsSQLite("username") & ", " & rsSQLite("email") rsSQLite.MoveNext Loop rsSQLite.Close sqliteConn.Close Else Debug.Print "无法连接SQLite数据库: " & Err.Description End If On Error GoTo 0 ' 3. 连接MySQL数据库(需要安装MySQL ODBC驱动) Dim mysqlConn As ADODB.Connection Set mysqlConn = New ADODB.Connection mysqlConn.ConnectionString = "Driver={MySQL ODBC 8.0 Unicode Driver};" & _ "Server=localhost;" & _ "Database=testdb;" & _ "User=root;" & _ "Password=123456;" & _ "Option=3;" On Error Resume Next mysqlConn.Open If mysqlConn.State = adStateOpen Then Debug.Print "成功连接MySQL数据库" Dim rsMySQL As ADODB.Recordset Set rsMySQL = New ADODB.Recordset rsMySQL.Open "SHOW TABLES", mysqlConn Debug.Print "MySQL表列表:" Do Until rsMySQL.EOF Debug.Print rsMySQL(0) rsMySQL.MoveNext Loop rsMySQL.Close mysqlConn.Close Else Debug.Print "无法连接MySQL数据库: " & Err.Description End If On Error GoTo 0 ' 清理对象 Set rsExcel = Nothing Set excelConn = Nothing Set rsSQLite = Nothing Set sqliteConn = Nothing Set rsMySQL = Nothing Set mysqlConn = Nothing End Sub

Sub AdvancedDatabaseTechniques() Dim conn As ADODB.Connection Dim rs As ADODB.Recordset Dim cmd As ADODB.Command Set conn = New ADODB.Connection conn.ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _ ThisWorkbook.Path & "\sample.accdb" conn.Open ' 1. 存储过程调用 Set cmd = New ADODB.Command cmd.ActiveConnection = conn cmd.CommandType = adCmdStoredProc cmd.CommandText = "GetCustomerOrders" ' 添加输入参数 Dim param As ADODB.Parameter Set param = cmd.CreateParameter("CustomerID", adVarChar, adParamInput, 5, "ALFKI") cmd.Parameters.Append param ' 执行存储过程 Set rs = cmd.Execute Debug.Print "客户ALFKI的订单:" Do Until rs.EOF Debug.Print rs("OrderID") & ", " & rs("OrderDate") rs.MoveNext Loop rs.Close ' 2. 批量操作 conn.BeginTrans Dim i As Integer For i = 1 To 10 conn.Execute "INSERT INTO TestTable (ID, Value) VALUES (" & i & ", '测试" & i & "')" Next i conn.CommitTrans Debug.Print "批量插入完成" ' 3. 分页查询 Dim pageSize As Integer: pageSize = 5 Dim pageNum As Integer: pageNum = 2 Set rs = New ADODB.Recordset rs.CursorLocation = adUseClient rs.Open "SELECT * FROM Customers ORDER BY CustomerID", conn, adOpenStatic, adLockReadOnly ' 计算分页 rs.Move (pageNum - 1) * pageSize Debug.Print "第" & pageNum & "页数据:" Dim count As Integer: count = 0 Do Until rs.EOF Or count >= pageSize Debug.Print rs("CustomerID") & ", " & rs("CompanyName") rs.MoveNext count = count + 1 Loop rs.Close ' 4. 数据导出到Excel Set rs = conn.Execute("SELECT * FROM Customers") Dim exportWs As Worksheet Set exportWs = ThisWorkbook.Sheets.Add exportWs.Name = "导出数据" ' 写入表头 For i = 0 To rs.Fields.Count - 1 exportWs.Cells(1, i + 1).Value = rs.Fields(i).Name Next i ' 写入数据 exportWs.Range("A2").CopyFromRecordset rs ' 5. 从Excel导入数据 conn.BeginTrans Dim importWs As Worksheet Set importWs = ThisWorkbook.Sheets("导入数据") Dim lastRow As Long lastRow = importWs.Cells(importWs.Rows.Count, "A").End(xlUp).Row For i = 2 To lastRow Dim customerID As String: customerID = importWs.Cells(i, 1).Value Dim companyName As String: companyName = importWs.Cells(i, 2).Value conn.Execute "INSERT INTO Customers (CustomerID, CompanyName) " & _ "VALUES ('" & customerID & "', '" & companyName & "')" Next i conn.CommitTrans Debug.Print "数据导入完成" ' 清理 rs.Close conn.Close Set rs = Nothing Set conn = Nothing End Sub

Sub BasicDebugging() ' 1. 使用Debug.Print输出信息 Debug.Print "调试开始: " & Now() ' 2. 设置断点 - 在代码行左侧灰色区域点击 Dim i As Integer For i = 1 To 5 Debug.Print "循环计数: " & i ' 在此行设置断点 Next i ' 3. 使用Stop语句 If i > 3 Then Stop ' 程序执行到此会暂停 End If ' 4. 使用立即窗口 ' 在中断模式下，可以在立即窗口中: ' - 查看变量值: ?i ' - 执行代码: i = 10 ' - 调用过程: Call MySub ' 5. 使用本地窗口查看所有变量 ' 6. 使用监视窗口跟踪特定变量或表达式 ' 右键变量 -> 添加监视 ' 7. 逐语句执行(F8) ' 8. 逐过程执行(Shift+F8) ' 9. 跳出(Ctrl+Shift+F8) ' 10. 设置下一条语句(右键代码 -> 设置下一条语句) Debug.Print "调试结束: " & Now() End Sub

Sub ErrorHandlingTechniques() ' 1. 基本错误处理 On Error GoTo ErrorHandler ' 可能出错的代码 Dim result As Double result = 1 / 0 ' 除零错误 ' 正常退出 Exit Sub ErrorHandler: Debug.Print "错误 " & Err.Number & ": " & Err.Description ' 恢复执行 Resume Next ' 2. 集中错误处理 On Error GoTo CentralErrorHandler ' 多个可能出错的操作 Dim fileNum As Integer fileNum = FreeFile Open "不存在的文件.txt" For Input As #fileNum ' 文件不存在错误 Close #fileNum Exit Sub CentralErrorHandler: Select Case Err.Number Case 53 ' 文件未找到 Debug.Print "文件未找到，请检查路径" Case 11 ' 除零错误 Debug.Print "数学计算错误" Case Else Debug.Print "未处理的错误: " & Err.Description End Select Resume Next ' 3. 嵌套错误处理 OuterProcedure ' 4. 记录错误日志 On Error GoTo LogError ' 业务代码... Exit Sub LogError: Call WriteErrorLog(Err.Number, Err.Description, "ErrorHandlingTechniques") Resume Next End Sub Sub OuterProcedure() On Error GoTo OuterHandler InnerProcedure Exit Sub OuterHandler: Debug.Print "外部过程错误: " & Err.Description Resume Next End Sub Sub InnerProcedure() On Error GoTo InnerHandler ' 模拟错误 Dim x As Variant x = 1 / 0 Exit Sub InnerHandler: Debug.Print "内部过程错误: " & Err.Description ' 可以选择继续抛出错误 Err.Raise Err.Number, "InnerProcedure: " & Err.Source, Err.Description End Sub Sub WriteErrorLog(errNum As Long, errDesc As String, procName As String) Dim logFile As Integer logFile = FreeFile Open "error.log" For Append As #logFile Print #logFile, "[" & Now() & "] 错误 " & errNum & " 在 " & procName & ": " & errDesc Close #logFile End Sub

Sub DebugToolsAndWindows() ' 1. 立即窗口 (Ctrl+G) ' - 打印变量值: Debug.Print x ' - 执行代码: x = 10 ' - 调用过程: Call MyProcedure ' 2. 本地窗口 ' - 显示当前过程中所有变量及其值 Dim localVar1 As Integer: localVar1 = 42 Dim localVar2 As String: localVar2 = "测试" ' 3. 监视窗口 ' - 添加监视表达式: localVar1 > 40 ' - 右键变量 -> 添加监视 ' 4. 调用堆栈 (Ctrl+L) ' - 显示当前调用链 Call FirstLevel ' 5. 断点管理 ' - 设置/清除断点: F9 ' - 禁用断点: 右键断点 -> 禁用 ' - 设置条件断点: 右键断点 -> 条件... ' 6. 运行到光标处 (Ctrl+F8) ' - 将光标放在目标行 -> Ctrl+F8 ' 7. 快速监视 (Shift+F9) ' - 选中表达式 -> Shift+F9 ' 8. 编辑并继续 ' - 在中断模式下修改代码 -> 继续执行(F5) End Sub Sub FirstLevel() Call SecondLevel End Sub Sub SecondLevel() Debug.Print "调用堆栈演示" ' 在此处查看调用堆栈 End Sub

Sub PerformanceProfiling() ' 1. 计时代码执行 Dim startTime As Double startTime = Timer ' 要测试的代码 Call SlowOperation Debug.Print "执行时间: " & Round(Timer - startTime, 2) & "秒" ' 2. 使用Application.EnableEvents避免事件循环 Application.EnableEvents = False ' 修改单元格等操作 Application.EnableEvents = True ' 3. 使用ScreenUpdating提高速度 Application.ScreenUpdating = False ' 批量操作 Application.ScreenUpdating = True ' 4. 使用数组而非单元格操作 Dim data() As Variant data = Range("A1:B10000").Value ' 一次性读取 ' 处理数组 Dim i As Long For i = LBound(data, 1) To UBound(data, 1) data(i, 2) = data(i, 1) * 2 Next i ' 一次性写回 Range("A1:B10000").Value = data ' 5. 减少工作表访问 Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(1) ' 不好 - 每次循环都访问工作表 ' For i = 1 To 100 ' ws.Cells(i, 1).Value = i ' Next ' 好 - 使用变量 Dim temp As Integer For i = 1 To 100 temp = i ws.Cells(i, 1).Value = temp Next ' 6. 禁用自动计算 Application.Calculation = xlCalculationManual ' 大量公式操作 Application.Calculation = xlCalculationAutomatic ' 7. 使用With语句减少对象引用 With ws.Range("A1:Z100") .Font.Bold = True .Interior.Color = RGB(255, 255, 0) .Value = "测试" End With End Sub Sub SlowOperation() Dim i As Long, j As Long Dim result As Double For i = 1 To 1000 For j = 1 To 1000 result = result + Sqr(i * j) Next j Next i Debug.Print "计算结果: " & result End Sub

' 需要在模块顶部声明API函数 #If VBA7 Then ' 64位Office Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr Private Declare PtrSafe Function SetWindowText Lib "user32" Alias "SetWindowTextA" _ (ByVal hwnd As LongPtr, ByVal lpString As String) As Long Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long #Else ' 32位Office Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" _ (ByVal hwnd As Long, ByVal lpString As String) As Long Private Declare Function GetTickCount Lib "kernel32" () As Long #End If Sub WindowsAPIDemo() ' 1. 查找并修改窗口标题 Dim hwnd As LongPtr hwnd = FindWindow(vbNullString, "无标题 - 记事本") If hwnd <> 0 Then SetWindowText hwnd, "API修改的标题" MsgBox "记事本标题已修改" Else MsgBox "未找到记事本窗口" End If ' 2. 获取系统运行时间 Dim ticks As Long ticks = GetTickCount() Dim seconds As Long seconds = ticks \ 1000 Dim minutes As Long minutes = seconds \ 60 Dim hours As Long hours = minutes \ 60 Debug.Print "系统已运行: " & hours & "小时 " & (minutes Mod 60) & "分钟" ' 3. 更多API示例 ' - 操作文件对话框 ' - 修改注册表 ' - 系统托盘图标 ' - 键盘钩子 End Sub

' 类模块: CPerson ' 属性 Private pName As String Private pAge As Integer Private pEmail As String ' 属性访问器 Public Property Get Name() As String Name = pName End Property Public Property Let Name(value As String) pName = value End Property Public Property Get Age() As Integer Age = pAge End Property Public Property Let Age(value As Integer) If value >= 0 Then pAge = value Else Err.Raise 5, "CPerson.Age", "年龄不能为负数" End If End Property Public Property Get Email() As String Email = pEmail End Property Public Property Let Email(value As String) If InStr(value, "@") > 0 Then pEmail = value Else Err.Raise 5, "CPerson.Email", "无效的邮箱地址" End If End Property ' 方法 Public Sub Introduce() Debug.Print "我叫" & pName & ", " & pAge & "岁, 邮箱是" & pEmail End Sub Public Function IsAdult() As Boolean IsAdult = (pAge >= 18) End Function ' 类模块: CEmployee (继承自CPerson) Private pSalary As Currency Private pDepartment As String Public Property Get Salary() As Currency Salary = pSalary End Property Public Property Let Salary(value As Currency) pSalary = value End Property Public Property Get Department() As String Department = pDepartment End Property Public Property Let Department(value As String) pDepartment = value End Property Public Sub ShowInfo() Debug.Print "员工" & Name & "(" & Age & "岁), 部门: " & Department & ", 薪资: " & FormatCurrency(Salary) End Sub ' 使用类的代码 Sub ClassDemo() Dim person As CPerson Set person = New CPerson ' 设置属性 person.Name = "张三" person.Age = 25 person.Email = "zhangsan@example.com" ' 调用方法 person.Introduce Debug.Print "是否成年: " & person.IsAdult ' 使用继承类 Dim emp As CEmployee Set emp = New CEmployee emp.Name = "李四" emp.Age = 30 emp.Email = "lisi@company.com" emp.Department = "财务部" emp.Salary = 8000 emp.ShowInfo emp.Introduce ' 调用父类方法 End Sub

' 使用Windows API创建线程 #If VBA7 Then Private Declare PtrSafe Function CreateThread Lib "kernel32" _ (lpThreadAttributes As Any, ByVal dwStackSize As Long, _ ByVal lpStartAddress As LongPtr, lpParameter As Any, _ ByVal dwCreationFlags As Long, lpThreadId As Long) As LongPtr #Else Private Declare Function CreateThread Lib "kernel32" _ (lpThreadAttributes As Any, ByVal dwStackSize As Long, _ ByVal lpStartAddress As Long, lpParameter As Any, _ ByVal dwCreationFlags As Long, lpThreadId As Long) As Long #End If Sub MultiThreadingDemo() ' 1. 使用Application.OnTime模拟异步 Application.OnTime Now + TimeValue("00:00:05"), "DelayedProcedure" Debug.Print "主过程继续执行..." ' 2. 使用类模块实现回调 Dim asyncTask As CAsyncTask Set asyncTask = New CAsyncTask asyncTask.StartTask "参数", "CallbackProcedure" Debug.Print "任务已启动..." ' 3. 使用API创建线程(高级) ' 注意: VBA不是线程安全的,需谨慎使用 ' Dim threadId As Long ' CreateThread ByVal 0&, ByVal 0&, AddressOf ThreadProcedure, ByVal 0&, ByVal 0&, threadId End Sub Sub DelayedProcedure() Debug.Print "延迟过程在 " & Now() & " 执行" End Sub Sub CallbackProcedure(result As String) Debug.Print "回调结果: " & result End Sub ' 类模块: CAsyncTask Public Sub StartTask(param As String, callback As String) ' 使用Application.OnTime模拟异步 Application.OnTime Now + TimeValue("00:00:03"), "'" & callback & """完成任务""'" End Sub

Sub AutomateOtherApps() ' 1. 自动化Word Dim wordApp As Object On Error Resume Next Set wordApp = GetObject(, "Word.Application") If wordApp Is Nothing Then Set wordApp = CreateObject("Word.Application") End If On Error GoTo 0 wordApp.Visible = True Dim wordDoc As Object Set wordDoc = wordApp.Documents.Add wordDoc.Content.Text = "这是从Excel自动创建的Word文档" & vbCrLf & Now() wordDoc.SaveAs ThisWorkbook.Path & "\AutoDoc.docx" ' 2. 自动化Outlook发送邮件 Dim outlookApp As Object Set outlookApp = CreateObject("Outlook.Application") Dim mailItem As Object Set mailItem = outlookApp.CreateItem(0) ' 0=olMailItem With mailItem .To = "recipient@example.com" .CC = "cc@example.com" .Subject = "自动发送的邮件" .Body = "这是一封自动生成的测试邮件。" & vbCrLf & _ "发送时间: " & Now() .Attachments.Add ThisWorkbook.Path & "\AutoDoc.docx" .Send End With ' 3. 自动化PowerPoint Dim pptApp As Object Set pptApp = CreateObject("PowerPoint.Application") pptApp.Visible = True Dim pptPres As Object Set pptPres = pptApp.Presentations.Add Dim pptSlide As Object Set pptSlide = pptPres.Slides.Add(1, 1) ' 1=ppLayoutTitle pptSlide.Shapes(1).TextFrame.TextRange.Text = "自动创建的幻灯片" pptSlide.Shapes(2).TextFrame.TextRange.Text = "创建于 " & Now() ' 4. 自动化Internet Explorer Dim ieApp As Object Set ieApp = CreateObject("InternetExplorer.Application") ieApp.Visible = True ieApp.Navigate "https://www.example.com" ' 等待页面加载 Do While ieApp.Busy Or ieApp.ReadyState <> 4 DoEvents Loop ' 可以操作DOM元素 ' ieApp.Document.getElementById("search").Value = "VBA自动化" ' 清理对象 Set mailItem = Nothing Set outlookApp = Nothing Set wordDoc = Nothing Set wordApp = Nothing Set pptSlide = Nothing Set pptPres = Nothing Set pptApp = Nothing Set ieApp = Nothing End Sub

Sub AdvancedDataStructures() ' 1. 字典对象 Dim dict As Object Set dict = CreateObject("Scripting.Dictionary") dict.Add "Apple", "苹果" dict.Add "Banana", "香蕉" dict.Add "Orange", "橙子" Debug.Print "Apple的翻译: " & dict("Apple") Debug.Print "是否存在Banana: " & dict.Exists("Banana") ' 遍历字典 Dim key As Variant Debug.Print "字典内容:" For Each key In dict.Keys Debug.Print key & ": " & dict(key) Next ' 2. 集合对象 Dim coll As New Collection coll.Add "第一项" coll.Add "第二项" coll.Add "第三项", "Key3" ' 添加键 Debug.Print "集合第二项: " & coll(2) Debug.Print "键为Key3的项: " & coll("Key3") ' 3. 链表实现 Dim list As New CLinkedList list.Add "A" list.Add "B" list.Add "C" Debug.Print "链表内容:" Dim i As Integer For i = 1 To list.Count Debug.Print list.Item(i) Next ' 4. 二叉树实现 Dim tree As New CBinaryTree tree.Insert 50 tree.Insert 30 tree.Insert 70 tree.Insert 20 tree.Insert 40 tree.Insert 60 tree.Insert 80 Debug.Print "中序遍历:" tree.InOrderTraversal ' 5. 排序算法 Dim arr() As Variant: arr = Array(5, 2, 8, 1, 9, 3) Call QuickSort(arr, LBound(arr), UBound(arr)) Debug.Print "快速排序结果:" For i = LBound(arr) To UBound(arr) Debug.Print arr(i) Next End Sub ' 快速排序算法 Sub QuickSort(arr() As Variant, low As Long, high As Long) If low < high Then Dim pivot As Long pivot = Partition(arr, low, high) Call QuickSort(arr, low, pivot - 1) Call QuickSort(arr, pivot + 1, high) End If End Sub Function Partition(arr() As Variant, low As Long, high As Long) As Long Dim pivot As Variant: pivot = arr(high) Dim i As Long: i = low - 1 Dim j As Long For j = low To high - 1 If arr(j) <= pivot Then i = i + 1 Swap arr(i), arr(j) End If Next Swap arr(i + 1), arr(high) Partition = i + 1 End Function Sub Swap(ByRef a As Variant, ByRef b As Variant) Dim temp As Variant temp = a a = b b = temp End Sub ' 类模块: CLinkedList (链表实现) Private pHead As CListNode Private pCount As Integer Public Sub Add(value As Variant) Dim newNode As New CListNode newNode.Value = value If pHead Is Nothing Then Set pHead = newNode Else Dim current As CListNode Set current = pHead Do Until current.Next Is Nothing Set current = current.Next Loop Set current.Next = newNode End If pCount = pCount + 1 End Sub Public Property Get Count() As Integer Count = pCount End Property Public Property Get Item(index As Integer) As Variant If index < 1 Or index > pCount Then Err.Raise 9, "CLinkedList.Item", "索引越界" End If Dim current As CListNode Set current = pHead Dim i As Integer For i = 1 To index - 1 Set current = current.Next Next Item = current.Value End Property ' 类模块: CListNode (链表节点) Public Value As Variant Public Next As CListNode ' 类模块: CBinaryTree (二叉树实现) Private pRoot As CTreeNode Public Sub Insert(value As Integer) If pRoot Is Nothing Then Set pRoot = New CTreeNode pRoot.Value = value Else InsertNode pRoot, value End If End Sub Private Sub InsertNode(ByRef node As CTreeNode, value As Integer) If node Is Nothing Then Set node = New CTreeNode node.Value = value ElseIf value < node.Value Then InsertNode node.Left, value Else InsertNode node.Right, value End If End Sub Public Sub InOrderTraversal() InOrder pRoot End Sub Private Sub InOrder(node As CTreeNode) If Not node Is Nothing Then InOrder node.Left Debug.Print node.Value InOrder node.Right End If End Sub ' 类模块: CTreeNode (树节点) Public Value As Integer Public Left As CTreeNode Public Right As CTreeNode