VBA学习笔记

VBA学习笔记，学习的蓝色幻想教程，细小知识点都列举出来了，哪里不会点哪里，一起来看看啊吧。

VBA学习笔记（蓝色幻想教程）

• 1. VBE编辑器
  • 1. 常用快捷键
    • 打开宏编辑器： Alt+F11； 立即窗口：Ctrl+G 运行宏： F5 逐行运行宏代码： F8 中断宏代码： Ctrl+Break ‘出现无脑无限循环时候打断 打断点：鼠标单击对应代码左侧
  • 2. 监视窗口/本地窗口：视图选项卡调出
    • 立即窗口：代码调试时及时输出值 例如 ： 立即窗口输入：？range（"a1") 结果反馈：A1的值 代码输入：Debug.Print range（"a1") 立即窗口输出： A1的值
  • 3. 代码助手
    • 会员：VBA代码助手
    • 免费：VBE2021
      • 阿里云盘 https://www.aliyundrive.com/s/PsQShGziejm 提取码: 0d2i 点击链接保存，或者复制本段内容，打开「阿里云盘」APP ，无需下载极速在线查看，视频原画倍速播放。
• 2. 对象方法属性
  • 1. 对象
    • VBA对象 VBA中的对象其实就是我们操作的具有方法、属性的excel中支持的对象 Excel中的几个常用对象表示方法 1、工作簿 Workbooks 代表工作簿集合，所有的工作簿,Workbooks(N)，表示已打开的第N个工作簿 Workbooks ("工作簿名称") ActiveWorkbook 正在操作的工作簿 ThisWorkBook '代码所在的工作簿 2、工作表 Sheets("工作表名称") Sheet1 表示第一个插入的工作表,Sheet2表示第二个插入的工作表.... Sheets(n) 表示按排列顺序，第n个工作表 ActiveSheet 表示活动工作表，光标所在工作表 worksheet 也表示工作表，但不包括图表工作表、宏工作表等。 3、单元格 cells 所有单元格 Range ("单元格地址") Cells(行数,列数) Activecell 正在选中或编辑的单元格 Selection 正被选中或选取的单元格或单元格区域
  • 2. 属性
    • 一、VBA属性 VBA属性就是VBA对象所具有的特点 表示某个对象的属性的方法是 对象.属性=属性值
  • 3. 方法
    • 二 、VBA方法 VBA方法是作用于VBA对象上的动作 表示用某个方法作用于VBA的对象上，可以用下面的格式： Sub ttt4() 牛排.做 熟的程度:=七成熟 Range("A1").Copy Range("A2") End Sub
• 3. 判断语句
  • 
  • 1. If判断语句
    • Sub 判断1() '单条件判断 If Range("a1").Value > 0 Then Range("b1") = "正数" Else Range("b1") = "负数或0" End If End Sub Sub 判断2() '多条件判断 If Range("a1").Value > 0 Then Range("b1") = "正数" ElseIf Range("a1") = 0 Then Range("b1") = "等于0" ElseIf Range("B1") < 0 Then Range("b1") = "负数" End If End Sub Sub 多条件判断2() If Range("a1") <> "" And Range("a2") <> "" Then Range("a3") = Range("a1") * Range("a2") End If End Sub '多条件and连接或or连接
    • Like运算符
      • 字符串1 like 字符串2 Sub L1() Debug.Print "ABC" Like "ABc" '返回 flase End Sub 通配符? Sub L2() Debug.Print "BA" Like "?A" '判断BA是不是长度为2，且第二个字符为A End Sub 通配符* Sub L3() Debug.Print "Excel精英培训" Like "*cel*" '判断字符串中是否包括cel End Sub 判断含通配符的字符串 '把通配符放在[]内，就代表本身字符的对比 Sub l4() 'Debug.Print "QAB" Like "Q?B" True Debug.Print "QaB" Like "Q?B" True 'Debug.Print "Q?B" Like "Q[?]B" 判断是否包含？True 'Debug.Print "" End Sub 判断是指定位数数字# Sub l9() Debug.Print 59 Like "#" '判断数字是否为2个整数构成的 End Sub 判断在某个区间的字符- Sub L10() '[最小-最大最小1-最大1] Debug.Print "q" Like "[A-Za-z]" ' 判断q是不是字母 Debug.Print "H" Like "[A-GM-Z]" ' 判断H是不是在A-G，M-Z区间 Debug.Print 8 Like "[!2-9]" ' 判断8是不是在非2-9区间 End Sub 判断非在某个区间的字符! Sub L11() Debug.Print "A" Like "[!C-Z]" ' 判断A是不是不在C-Z区间 End Sub 判断在列出的字符里 Sub L12() Debug.Print "M" Like "[!ABCDEUE]" ' 判断M是不是不在ABCDEUE之间 End Sub 判断A~C开头，F~G结尾 Sub L13(） Debug.Print "AEREM" Like "[A-C]*[L-P]" ‘判断A~C开头，L~PG结尾 Debug.Print "A334M" Like "[A-C]###[L-P]" 判断A~C开头，中间3个字符，L~PG结尾 End Sub 
  • 2. Select判断
    • Sub 判断1() '单条件判断 Select Case Range("a1").Value Case Is > 0 Range("b1") = "正数" Case Else Range("b1") = "负数或0" End Select End Sub Sub 判断2() '多条件判断 Select Case Range("a1").Value Case Is > 0 Range("b1") = "正数" Case Is = 0 Range("b1") = "0" Case Else Range("b1") = "负数" End Select End Sub Sub 判断3()‘字母判断输出 If Range("a3") < "G" Then MsgBox "A-G" End If End Sub
  • 3. 范围判断
    • Sub if区间判断()‘区间有关联，无需重复写判断条件 If Range("a2") <= 1000 Then ’0-1000 Range("b2") = 0.01 ElseIf Range("a2") <= 3000 Then ‘1001-3000，大于1000已在第一次判断里，不用再次添加 Range("b2") = 0.03 ElseIf Range("a2") > 3000 Then ’3001-9999，这里可以简写：Else 后不加条件和then Range("b2") = 0.05 End If End Sub Sub select区间判断()’区间用 to连接 Select Case Range("a2").Value Case 0 To 1000 Range("b2") = 0.01 Case 1001 To 3000 Range("b2") = 0.03 Case Is > 3000 Range("b2") = 0.05 End Select End Sub
• 4. 循环语句
  • 金额循环求和 
  • 1. for循环
    • Sub t1() Range("d2") = Range("b2") * Range("c2") Range("d3") = Range("b3") * Range("c3") Range("d4") = Range("b4") * Range("c4") Range("d5") = Range("b5") * Range("c5") Range("d6") = Range("b6") * Range("c6") End Sub Sub t2() Dim x As Integer For x = 10000 To 2 Step -3 Range("d" & x) = Range("b" & x) * Range("c" & x) Next x End Sub
  • 2. for each循环
    • 金额求和： Sub t3() Dim rg As Range For Each rg In Range("d2:d18") rg = rg.Offset(0, -1) * rg.Offset(0, -2) Next rg End Sub  空格填充为0 Sub s1() Dim rg As Range For Each rg In Range("a1:b7,d5:e9") If rg = "" Then rg = 0 End If Next rg End Sub
  • 3. do loop循环
    • Sub t4() Dim x As Integer x = 1 Do x = x + 1 Cells(x, 4) = Cells(x, 2) * Cells(x, 3) Loop Until x = 18 End Sub Sub t5() x = 1 Do While x < 18 x = x + 1 Cells(x, 4) = Cells(x, 2) * Cells(x, 3) Loop End Sub
• 5. 变量
  • 1. 变量数据类型
    • Dim 变量 As 数据类型
  • 2. 模块级变量
    • Dim 变量 As 数据类型
  • 3. 全局变量: 所有模块调用
    • Public 变量 As 数据类型
• 6. 公式与函数
  • 1. 单元格插入普通公式
    • Sub t1() Range("d2") = "=b2*c2" End Sub
  • 2. 带引号的公式：遇到单引号就把单引号加倍
    • Sub t3() Range("c16") = "=SUMIF(A2:A6,""b"",B2:B6)" '遇到单引号就把单引号加倍 End Sub
  • 3. 输入数组公式
    • Sub t4() Range("c9").FormulaArray = "=SUM(B2:B6*C2:C6)" End Sub
  • 4. 利用单元格公式返回值
    • Sub t5() Range("d16") = Evaluate("=SUMIF(A2:A6,""b"",B2:B6)") Range("d9") = Evaluate("=SUM(B2:B6*C2:C6)") End Sub ‘Evaluate：直接返回值
  • 5. 借用工作表函数
    • Sub t6(0 Range("d8") = Application.WorksheeFunction.CountIf(Range("A1:A10"), "B") End Sub
  • 6. 利用VBA函数
    • Sub t7() Range("C20") = VBA.InStr(Range("a20"), "E") End Sub
  • 7. 编写自定义函数 Function
    • 1 什么是自定义函数？ 在VBA中有VBA函数，我们还可以调用工作表函数，自定义函数 '2 怎么编写自定义函数？ '我们可以按下面的结构编写自定义函数 ' Function 函数名称(参数1,参数2....) '代码 '函数名称=返回的值或数组 ' End Function
    • 常见问题
      • 1 怎么让自定义函数在所有工作簿中使用？ '答： 把含有自定义函数的文件另存为加截宏，然后通过工具-加截宏-浏览找到这个文件-确定。 2 怎么给自定义函数添加说明 '工具-宏-宏名输入自定义函数的名称-选项--在说明栏中写入这个函数的名称 3、怎么给自定义函数分类 Sub 分类() Application.MacroOptions "不重复个数", Category:=4 End Sub '注: '0 是全部 '1 财务 '2 日期和时间 '3 数学和三角 '4 统计 '5 查找和引用 '6 数据库 '7 文本 '8 逻辑 '9 信息
    • 返回数组的自定义函数
      • '返回一个固定区间固定个数的不重复随数 Function shuiji(maxnum, geshu) 'maxnum是区间最大的数,geshu是返回多少个不重复的数 Dim d As New Dictionary Dim num Application.Volatile ’工作表自动更新该公式 Do num = Int(Rnd() * maxnum + 1) d(num) = "" Loop Until d.Count = geshu shuiji = Application.Transpose(d.Keys) End Function rand():返回大于等于0且小于1的随机数 int（）：取整数，像下取整为最接近的整数 int（99.8）=99 int（-99.8）=-100 fix():取整数，像最靠近0取整 fix（99.8）=99 fix（-99.8）=-99
    • 参数默认和参数缺省
      • Function shuiji1(maxnum, geshu, Optional qo As Integer)‘加Optional表示参数设置 Dim d As New Dictionary Dim num Application.Volatile Do num = Int(Rnd() * maxnum + 1) If qo = 0 Then ’参数省略不写时，返回随机数 d(num) = "" ElseIf qo = 2 Then ’参数等于2时，返回随机数偶数 If num Mod 2 = 0 Then d(num) = "" ElseIf qo = 1 Then’参数等于1时，返回随机数奇数 If Not num Mod 2 = 0 Then d(num) = "" End If Loop Until d.Count = geshu shuiji1 = Application.Transpose(d.Keys) End Function ’实现返回一个随机数/随机偶数/随机奇数 Function shuiji2(maxnum, geshu, Optional qo As Integer = 2) ’设置默认参数，当省略时，默认2 Dim d As New Dictionary Dim num, m Application.Volatile Do num = Int(Rnd() * maxnum + 1) If qo = 2 Then If num Mod 2 = 0 Then d(num) = "" ElseIf qo = 1 Then If Not num Mod 2 = 0 Then d(num) = "" Else Exit Function End If Loop Until d.Count = geshu shuiji2 = Application.Transpose(d.Keys) End Function
    • 参数不定或多参数
      • ‘sum函数 Function cheng(ParamArray n()) Dim num, k k = 0 For Each num In n k = k + num Next num cheng = k End Function
• 7. 分支与End语句
  • 1. END语句：强制退出所有正在运行的程序
  • 2. Exit语句：退出指定的语句
    • 1、Exit Sub Sub e1() Dim x As Integer For x = 1 To 100 Cells(1, 1) = x If x = 5 Then Exit Sub End If Next x Range("b1") = 100 End Sub 2、Exit function 3、Exit for Sub e2() Dim x As Integer For x = 1 To 100 Cells(1, 1) = x If x = 5 Then Exit For End If Next x End Sub 4、Exit do Sub e3() Dim x As Integer Do x = x + 1 Cells(1, 1) = x If x = 5 Then Exit Do End If Loop Until x = 100 End Sub
  • 3. 分支语句
    • 
    • 1. Goto语句：跳转到指定的地方
      • Sub t1() Dim x As Integer Dim sr 100: sr = Application.InputBox("请输入数字", "输入提示") If Len(sr) = 0 Or Len(sr) = 5 Then GoTo 100 ‘Len(sr) = 0 未输入 Len(sr) = 5 取消输入 End Sub
    • 2. gosub..return：跳过去,再跳回来
      • Sub t2() Dim x As Integer For x = 1 To 10 If Cells(x, 1) Mod 2 = 0 Then GoSub 100 Next x Exit Sub’防止继续运行100，提前结束 100: Cells(x, 1) = "偶数" Return '跳到gosub 100 这一句 End Sub
    • 3. on error resume next :遇到错误,跳过继续执行下一句
      • Sub t3() On Error Resume Next Dim x As Integer For x = 1 To 10 Cells(x, 3) = Cells(x, 2) * Cells(x, 1) Next x End Sub
    • 4. on error goto :出错时跳到指定的行数
      • Sub t4() On Error GoTo 100 Dim x As Integer For x = 1 To 10 Cells(x, 3) = Cells(x, 2) * Cells(x, 1) Next x Exit Sub’防止继续运行100，提前结束 100: MsgBox "在第" & x & "行出错了" End Sub
    • 5. on error goto 0 : 取消错误跳转
      • Sub t5() On Error Resume Next Dim x As Integer For x = 1 To 10 If x > 5 Then On Error GoTo 0 Cells(x, 3) = Cells(x, 2) * Cells(x, 1) Next x Exit Sub End Sub
• 8. Excle文件操作
  • 1. 文件操作
    • excel文件和工作簿 excel文件就是excel工作簿，excel文件打开需要excel程的支持 Workbooks 工作簿集合，泛指excel文件或工作簿 Workbooks("A.xls")，名称为A的excel工作簿 Workbooks(2)，按打开顺序，第二个打开的工作簿。 ActiveWorkbook ，当打开多个excel工作簿时，你正在操作的那个就是ActiveWorkbook（活动工作簿） Thisworkbook，VBA程序所在的工作簿，无论你打开多少个工作簿，无论当前是哪个工作簿是活动的,thisworkbook就是指它所在的工作簿。 '工作簿窗口 Windows("A.xls"),A工作簿的窗口，使用windows可以设置工作簿窗口的状态，如是否隐藏等。 Sub t3() Windows("A.xls").Visible = False ‘隐藏 End Sub Sub t4() Windows(2).Visible = True ’显示 End Sub
    • 1. 判断A.Xls文件是否存在
      • Sub W1() If Len(Dir("d:/A.xls")) = 0 Then MsgBox "A文件不存在" Else MsgBox "A文件存在" End If End Sub
    • 2. 判断A.Xls文件是否打开
      • Sub W2() Dim X As Integer For X = 1 To Windows.Count If Windows(X).Caption = "A.XLS" Then MsgBox "A文件打开了" Exit Sub End If Next MsgBox "A文件没有打开" End Sub
    • 3. excel文件新建和保存
      • Sub W3() Dim wb As Workbook Set wb = Workbooks.Add wb.Sheets("sheet1").Range("a1") = "abcd" wb.SaveAs "D:/B.xls" End Sub
    • 4. excel文件打开和关闭
      • Sub w4() Dim wb As Workbook Set wb = Workbooks.Open("D:/B.xls") ‘把open设置为对象属性时open后面需要加（） MsgBox wb.Sheets("sheet1").Range("a1").Value wb.Close False ’False不保存；TRUE 保存 End Sub
    • 5. excel文件保存和备份
      • Sub w5() Dim wb As Workbook Set wb = ThisWorkbook wb.Save wb.SaveCopyAs "D:/ABC.xls" End Sub
    • 6. excel文件复制和删除
      • Sub W6() FileCopy "D:/ABC.XLS", "E:/ABCd.XLS" ’FileCopy 原始文件 复制文件 Kill "D:/ABC.XLS" End Sub
  • 2. 工作表操作
    • excel工作表有两大类，一类是我们平常用的工作表(worksheet)，另一类是图表、宏表等。这两类的统称是sheets sheets 工作表集合，泛指excel各种工作表 Sheets("A")，名称为A的excel工作表 workbooks(2)，按打开顺序，第二个打开的工作簿。 ActiveSheet ，当打开多个excel工作簿时，你正在操作的那个就是ActiveSheet
    • 1. 判断A工作表文件是否存在
      • Sub s1() Dim X As Integer For X = 1 To Sheets.Count If Sheets(X).Name = "A" Then MsgBox "A工作表存在" Exit Sub‘找到了就直接退出sub End If Next MsgBox "A工作表不存在" End Sub
    • 2. excel工作表的插入
      • Sub s2() Dim sh As Worksheet Set sh = Sheets.Add sh.Name = "模板" sh.Range("a1") = 100 End Sub
    • 3. excel工作表隐藏和取消隐藏
      • Sub s3() Sheets(2).Visible = True' True 隐藏 False 不隐藏 End Sub
    • 4. excel工作表的移动
      • Sub s4() Sheets("Sheet2").Move before:=Sheets("sheet1") 'sheet2移动到sheet1前面 Sheets("Sheet1").Move after:=Sheets(Sheets.Count) 'sheet1移动到所有工作表的最后面 End Sub
    • 5. excel工作表的复制
      • Sub s5() '在本工作簿中 Dim sh As Worksheet Sheets("模板").Copy before:=Sheets(1) Set sh = ActiveSheet sh.Name = "1日" sh.Range("a1") = "测试" End Sub
    • 6. 另存为新工作簿
      • Sub s6() '另存为新工作簿 Dim wb As Workbook Sheets("模板").Copy Set wb = ActiveWorkbook wb.SaveAs ThisWorkbook.Path & "/1日.xls" wb.Sheets(1).Range("b1") = "测试" wb.Close True End Sub
    • 7. 保护工作表
      • Sub s7() ’设置密码 Sheets("sheet2").Protect "123" ’Protect 文件密码 End Sub Sub s8() '判断工作表是否添加了保护密码 If Sheets("sheet2").ProtectContents = True Then MsgBox "工作簿保护了" Else MsgBox "工作簿没有添加保护" End If End Sub
    • 8. 工作表删除
      • Sub s8() Application.DisplayAlerts = False‘删除弹窗关闭 Sheets("模板").Delete Application.DisplayAlerts = True‘删除弹窗关闭 End Sub
    • 9. 工作表的选取
      • Sub s10() Sheets("sheet2").Select End Sub
• 9. 单元格选取
  • 1. 表示一个单元格(a1)
    • Sub s() Range("a1").Select Cells(1, 1).Select Range("A" & 1).Select Cells(1, "A").Select Cells(1).Select [a1].Select End Sub
  • 2. 表示相邻单元格区域
    • Sub d() '选取单元格a1:c5 Range("a1:c5").Select‘区域选取： Range("A1", "C5").Select ‘区域两对角点 Range(Cells(1, 1), Cells(5, 3)).Select Range("a1:a10").Offset(0, 1).Select ’区域向下偏移0个单元格，向右偏移1个单元格，得到Range（"B1：B10") Range("a1").Resize(5, 3).Select ’A1向下扩展5行，向右扩展3列（包含A1所在行列），得到Range（"A1：C5") End Sub
  • 3. 表示不相邻的单元格区域
    • Sub d1() Range("a1,c1:f4,a7").Select Union(Range("a1"), Range("c1:f4"), Range("a7")).Select End Sub Sub dd() 'union示例 Dim rg As Range, x As Integer For x = 2 To 10 Step 2 If x = 2 Then Set rg = Cells(x, 1) END IF Set rg = Union(rg, Cells(x, 1)) Next x rg.Select End Sub
  • 4. 表示行
    • Sub h() Rows(1).Select '按行号 Rows("3:7").Select ‘连续区域 Range("1:2,4:5").Select ’不连续区域 Range("c4:f5").EntireRow.Select‘返回选中区域的行号
  • 5. 表示列
    • Sub L()‘用法与行相似 Columns(1).Select Columns("A:B").Select Range("A:B,D:E").Select Range("c4:f5").EntireColumn.Select '返回选取c4:f5所在的列 End Sub
  • 6. 重置坐标下的单元格表示方法
    • Sub cc() Range("b2").Range("a1") = 100 End Sub
  • 7. 表示正在选取的单元格区域
    • Sub d2() Selection.Value = 100 End Sub
• 10. 特殊单元格定位
  • 1. 已使用的单元格区域
    • Sub d1() Sheets("sheet2").UsedRange.Select ’已使用的单元格 End Sub
  • 2. 某单元格所在的单元格区域
    • Sub d2() Range("b8").CurrentRegion.Select ‘连续区域 End Sub
  • 3. 两个单元格区域共同的区域
    • Sub d3() Intersect(Columns("b:c"), Rows("3:5")).Select ’Intersect（区域1，区域2） End Sub
  • 4. 调用定位条件选取特殊单元格
    • Sub d4() Range("A1:A6").SpecialCells(xlCellTypeBlanks).Select End Sub
  • 5. 端点单元格（最大行）
    • Sub d5() cells(cells.count,1).End(xlUp).Offset(1, 0) = 1000 ’A列最后一个有内容的单元格向下偏移一格 End Sub
• 11. 单元格信息
  • 1. 单元格的值
    • Sub x1() Range("b10") = Range("c2").Value ’单元格的值 Range("b11") = Range("c2").Text ‘单元格内能看到的 Range("c10") = "'" & Range("I3").Formula ’单元格公式 End Sub
  • 2. 单元格的地址
    • Sub x2() With Range("b2").CurrentRegion ‘range（“B2:B16”） [b12] = .Address '绝对地址$B$2:$I$6 [c12] = .Address(0, 0) ‘B2:I6 [d12] = .Address(1, 0) ’B$2:I$6 [e12] = .Address(0, 1) ‘$B2:$I6 [f12] = .Address(1, 1) ’$B$2:$I$6 End With End Sub
  • 3. 单元格的行列信息
    • Sub x3() With Range("b2").CurrentRegion 'range（“B2:B16”） [b13] = .Row '2 区域首行 [b14] = .Rows.Count '5 区域总行数 [b15] = .Column '2 区域首列 [b16] = .Columns.Count '8 区域总列数 [b17] = .Range("a1").Address '$B$2 区域第一个单元格 End With End Sub
  • 4. 单元格的格式信息
    • Sub x4() With Range("b2") [b19] = .Font.Size ’字体大小 [b20] = .Font.ColorIndex‘字体颜色 [b21] = .Interior.ColorIndex ’字体背景色 [b22] = .Borders.LineStyle‘边框类型 End With End Sub
  • 5. 单元格批注信息
    • Sub x5() [B24] = Range("I2").Comment.Text End Sub
  • 6. 单元格的位置信息
    • Sub x6() With Range("b3") [b26] = .Top ’单元格的顶部位置 [b27] = .Left‘单元格左边距 [b28] = .Height ’单元格的高度 [b29] = .Width‘单元格的宽度 End With End Sub
  • 7. 单元格的上级信息
    • Sub x7() With Range("b3") [b31] = .Parent.Name ’单元格的上一级sheet [b32] = .Parent.Parent.Name‘单元格的上一级的上一级excle工作表 End With End Sub
  • 8. 内容判断
    • Sub x8() With Range("i3") [b34] = .HasFormula ’是否有公式 [b35] = .Hyperlinks.Count‘超链接 End With End Sub
• 12. 单元编辑输入
  • 1. 单元格输入
    • Sub t1() Range("a1") = "a" & "b" Range("b1") = "a" & Chr(10) & "b" '换行输入 End Sub
  • 2. 单元格复制和剪切
    • Sub t2() Range("a1:a10").Copy Range("c1") 'A1：A10的内容复制到C1 End Sub Sub t3() Range("a1:a10").Copy ActiveSheet.Paste Range("d1") '粘贴至D1 End Sub Sub t4() Range("a1:a10").Copy Range("e1").PasteSpecial (xlPasteValues) '只粘贴为数值 End Sub Sub t5() Range("a1:a10").Cut ActiveSheet.Paste Range("f1") '粘贴到f1 End Sub Sub t6() Range("c1:c10").Copy Range("a1:a10").PasteSpecial Operation:=xlAdd '选择粘贴-加 End Sub Sub T7() Range("G1:G10") = Range("A1:A10").Value End Sub
  • 3. 填充公式
    • Sub T8() Range("b1") = "=a1*10" Range("b1:b10").FillDown '向下填充公式 End Sub
  • 4. 行列的删除和插入
    • Sub c2() '插入行并复制公式 Rows(4).Insert ‘增加行 第四行上方插入一行，原始行变为5 Rows(4).Delete ’删除行 第4行删除，原第5行变为4 End Sub  Sub c4() Dim x As Integer, m1 As Integer, m2 As Integer Dim k As Integer m1 = 2 For x = 2 To 1000 If Cells(x, 1) = "" Then Exit Sub If Cells(x, 3) <> Cells(x + 1, 3) Then m2 = x Rows(x + 1).Insert Cells(x + 1, "c") = Cells(x, "c") & " 小计" Cells(x + 1, "h") = "=sum(h" & m1 & ":h" & m2 & ")" Cells(x + 1, "h").Resize(1, 4).FillRight Cells(x + 1, "i") = "" x = x + 1 m1 = m2 + 2 End If Next x End Sub
• 13. 单元格查找
  • 1. 使用循环查找
  • 2. 调用工作表函数
    • Sub c1() '判断是否存在,并查找所在行数 Dim hao As Integer Dim icount As Integer icount = Application.WorksheetFunction.CountIf(Sheets("库存明细表").[b:b], [g3]) If icount > 0 Then MsgBox "该入库单号码已经存在，请不要重复录入" MsgBox Application.WorksheetFunction.Match([g3], Sheets("库存明细表").[b:b], 0) End If End Sub ‘Application.WorksheetFunction.Match（需要查找的值，包含要查找值得连续单元格区域，匹配类型（0返回第一个位置））
  • 3. 使用Find方法
    • 3 使用Find方法 本示例在第一个工作表的单元格区域 A1:A500 中查找包含值 2 的所有单元格，并将这些单元格的值更改为 5。 Visual Basic for Applications With Worksheets(1).Range("a1:a500") Set c = .Find(2, lookin:=xlValues) If Not c Is Nothing Then firstAddress = c.Address Do c.Value = 5 Set c = .FindNext(c) Loop While Not c Is Nothing And c.Address <> firstAddress End If End With
• 14. 事件
  • 1. 工作表事件
  • 2. 工作簿事件
  • 3. 程序事件
    • Public WithEvents app As Excel.Application ’1定义一个程序事件变量 Private Sub app_WorkbookOpen(ByVal Wb As Workbook) ’做完1和2后建立app事件后，本例中再打开其他文件需输入密码，本文件关闭失效。永久生效需保存文件为加载宏文件，导入后可做到打开所有excle文件均需输入密码 ' a = Application.InputBox("请输入打开excel程序口令", "安全提示") ' If a <> 123 Then ' Wb.Close False ' End If End Sub Private Sub Workbook_Open() Set app = Excel.Application‘2把APP定义为程序事件 End Sub
• 15. 数组
  • 1、什么是VBA数组呢？ VBA数组就是储存一组数据的数据空间?数据类型可以数字,可以是文本,可以是对象,也可以是VBA数组. 2、 VBA数组存在形态 VBA数组是以变量形式存放的一个空间,它也有行有列，也可以是三维空间。 1) 常量数组 array(1,2) array(array(1,2,4),array("a","b","c")) 2) 静态数组 x(4) '有5个位置，编号从0~4 arr(1 to 10) '有10个位置，编号1~10 arr(1 to 10,1 to 2) '10行2列的空间，总共20个位置，这是二维数组 arr(1 to 10,1 to 2,1 to 3) '三维数组，总10*2*3=60个位置。这是三维数组 3)动态数组 arr() '不知道有多少行多少列
  • 1. 数组写入
    • 1、按编号(标)写入和读取 Sub t1() '写入一维数组 Dim x As Integer Dim arr(1 To 10) For x = 1 To 10 arr(x) = x Next End Sub Sub t2() '向二维数组写入数据和读取 Dim x As Integer, y As Integer Dim arr(1 To 5, 1 To 4) For x = 1 To 5 For y = 1 To 4 arr(x, y) = Cells(x, y) Next y Next x End Sub 2、动态数组 Sub t3() Dim arr() Dim row row = Sheets("sheet2").Range("a65536").End(xlUp).row - 1 ReDim arr(1 To row) For x = 1 To row arr(x) = Cells(x, 1) Next x Stop End Sub 3、批量写入 Sub t4() '由常量数组导入 Dim arr arr = Array(1, 2, 3, "a") Stop End Sub Sub t5() '由单元格区域导入 Dim arr arr = Range("a1:d5") Stop End Sub
  • 2. 数组读取
    • 1、在内存中读取 '在内存中读取后用于继续运算，直接用下面的格式 '数组变量(5) '数组变量(3,2) 例: arr = Range("a1:a10") 'range区域导入为二维数组 Dim arr1(1 To 10)‘一维数组 For x = 1 To 10 k = k + 1 arr1(k) = arr(x, 1) End If 2、读取存入单元格中 Sub d2() '二维数组存入单元格 Dim arr1(1 To 5, 1 To 1) Range("d2").Resize(5,1) = arr1‘二维数组存入单元格无需转置 End Sub Sub d3() '一维数组存入单元格 Dim arr1(1 To 5) Range("d2").Resize(5) = Application.Transpose(arr1) ‘一维数组存入单元格后为行排列，若想列排序需转置 Sub d4() '数组部分存入 数组数量大（10）可以存入小单元格数量（5） 数组数量小（5）存入单元格数量（10），多出的5个单元格为错误值
  • 3. 数组的空间大小
    • '1、数组的大小 数组是用编号排序的，那么如何获得一个数组的大小呢 'Lbound(数组) 可以获取数组的最小下标(编号) 'Ubound(数组) 可以获取数组的最大上标(编号) 'Ubound(数组,1) 可以获得数组的行方面(第1维)最大上标 'Ubound(数组,2) 可以获得数组的列方向(第2维)的最大上标 2、动态数组的动态扩充 '如果一个数组无法或不方便计算出总的大小，而在一些特殊情况下又不允许有空位。这时我们就需要用动态的导入方法 ' 'ReDim Preserve arr() 可以声明一个动态大小的数组，而且可以保留原来的数值，就相当于厂房小了，可以改扩建增大，但是它只能 '让最未维实现动态，如果是一维不存在最未维，只有一维 '3 清空数组 '清空数组使用earse语句 Erase arr1
  • 4. 数组与函数
    • 1. 可以生成数组的函数
      • 1. split函数
        • '按分隔符把字符串截取成VBA数组,该数组是一维数组，编号从0开始 split(字符串,分隔符) Sub t1() Dim sr, arr sr = "A-BC-FGR-H" arr = VBA.Split(sr, "-") MsgBox Join(arr, ",")‘join（数组，分隔符）可以按分隔符连接数组值 End Sub
      • 2. Filter函数
        • '按条件筛选符合条件的值组成一个新的数组 'Filter(数组,筛选条件,是/否)’‘模糊匹配时使用 '注：如果是（true）则返回包含的数组，如果否则返回非包含的数组 Sub t2() Dim arr, arr1, arr2 arr = Application.Transpose(Range("A2:A10")) arr1 = VBA.Filter(arr, "W", True) arr2 = VBA.Filter(arr, "W", False) Range("B2").Resize(UBound(arr1) + 1) = Application.Transpose(arr1) Range("C2").Resize(UBound(arr2) + 1) = Application.Transpose(arr2) End Sub
      • 3. index函数
        • '调用该工作表函数可以把二维数组的某一列或某一行截取出来，构成一个新的数组。 ' Application.Index(二维数组,0,列数)) 返回二维数组 ' Application.Index(二维数组,行数,0)) 返回一维数组 Sub t3() Dim arr, arr1, arr2 arr = Range("a2:d6") arr1 = Application.Index(arr, , 1) arr2 = Application.Index(arr, 4, 0) Stop End Sub
      • 4. vlookup函数
        • 'Vlookup函数的第一个参数可以用VBA数组，返回的也是一个VBA数组 Sub t4() Dim arr, arr1 arr = Range("a2:d6") arr1 = Application.VLookup(Array("B", "C"), arr, 4, 0) End Sub
      • 5. 5Sumif函数和Countif函数
        • Sumif函数和Countif函数 'Countif和sumif函数的第二个参数都可以使用数组，所以也可以返回一个VBA数组，如： Sub t5() Dim T T = Timer Dim arr，arr1 arr = Application.SumIf(Range("a2:a10000"), Array("B", "C", "G", "R"), Range("B2:B10000")) arr1 = Application.Countif(Range("a2:a10000"), Array("B", "C", "G", "R") ) MsgBox Timer - T Stop End Sub
    • 2. 数组处理
      • 1. 数组的最值
        • Sub s() Dim arr1() arr1 = Array(1, 12, 4, 5, 19) MsgBox "1, 12, 4, 5, 19最大值" & Application.Max(arr1) MsgBox "1, 12, 4, 5, 19最小值:" & Application.Min(arr1) MsgBox "1, 12, 4, 5, 19第二大值：" & Application.Large(arr1, 2) MsgBox "1, 12, 4, 5, 19第二小值：" & Application.Small(arr1, 2) End Sub
      • 2. 求和
        • application.Sum (数组)
      • 3. 统计个数
        • 'counta和count函数可以统计VBA数组的数字个数及所有已填充内容的个数 Sub s1() Dim arr1, arr2(0 To 10), x arr1 = Array("a", "3", "", 4, 6) For x = 0 To 4 arr2(x) = arr1(x) Next x MsgBox "数组1的数字个数：" & Application.Count(arr1) ’返回2 MsgBox "数组2的已填充数值的个数" & Application.CountA(arr2)‘返回11 End Sub
      • 4. 在数组里查找
        • Sub s2() Dim arr On Error Resume Next arr = Array("a", "c", "b", "f", "d") MsgBox Application.Match("f", arr, 0) ’0代表返回arr里第一次查找到“f”的位置行数 If Err.Number = 13 Then ’找不到时弹窗错误编号为13 MsgBox "查找不到" End If End Sub
    • 3. 数组与单元格格式
      • '数组也可以设置格式？ '数组除了数字类型外，当然没有颜色、字体等格式，但是别忘了range对象可以表示多个连续或不连续的单元格区域 '利用上述特点，我们就是要数组构造单元格地址串，然后批量对单元格进行格式设置。 '注意，单元格地址串不能>255，所以如果单元格操作过多，我们还需要分次分批设置单元格格式 例子：利用数组构造如下的单元格地址 Sub 填充颜色() Range("a2:d2,a7:d7,a10:d10").Interior.ColorIndex = 3 End Sub 具体例子： https://www.aliyundrive.com/s/R99Nwi1g8DT 提取码: 28zp
    • 4. 数组排序
      • 排序有很多大神已整理好，用的时候直接使用
• 16. 字典
  • 1 什么是VBA字典？ '字典（dictionary）是一个储存数据的小仓库。共有两列。 '第一列叫key , 不允许有重复的元素。 '第二列是item,每一个key对应一个item，本列允许为重复 'Key item 'A 10 'B 20 'C 30 'Z 10
  • 字典基础
    • 创建字典
      • 字典在哪里？如何创建字典？ 字典是由scrrun.dll链接库提供的，要调用字典有两种方法 '第一种方法：直接创建法 Set dic = CreateObject("scripting.dictionary") '第二种方法：引用法 '工具-引用-浏览-找到scrrun.dll-确定
    • 装入数据
      • Sub tv() Dim dic, x, i Set dic = CreateObject("scripting.dictionary") For i = 2 To 4 Key = Cells(i, 1) dic(Key) = Cells(i, 2) Next ' MsgBox dic.Keys()(0)‘读取key ' MsgBox dic.Keys()(1) ' MsgBox dic.Keys()(2) ' MsgBox dic.Items()(0) ’读取item，即key储存的值 MsgBox dic("张三")‘读取key为"张三" 的值 End Sub
    • 读取数据
      • Sub t2() Dim D Dim D As New Dictionary Dim arr Dim x As Integer Set D = CreateObject("scripting.dictionary") For x = 2 To 4 D.Add Cells(x, 1).Value, Cells(x, 2).Value Next x MsgBox D("李四") MsgBox D.Keys(2) Range("d1").Resize(D.Count) = Application.Transpose(D.Keys) ’keys相当于一维，放入单元格需转置 Range("e1").Resize(D.Count) = Application.Transpose(D.Items) arr = D.Items End Sub
    • 修改数据
      • Sub t3() Dim D As New Dictionary Dim x As Integer For x = 2 To 4 D.Add Cells(x, 1).Value, Cells(x, 2).Value Next x D("李四") = 78‘d("key")=值 该语句直接修改key保存的值 MsgBox D("李四") D("赵六") = 100 MsgBox D("赵六") End Sub
    • 删除数据
      • Sub t4() Dim D As New Dictionary Dim x As Integer For x = 2 To 4 D(Cells(x, 1).Value) = Cells(x, 2).Value Next x D.Remove "李四" ’移除key为李四的项目 ' MsgBox d.Exists("李四")‘ 判断是否存在李四这个字典 D.RemoveAll ’全部移除 MsgBox D.Count End Sub
  • 字典功能
    • 去重
      •  Sub 提取不重复的产品() Dim d As New Dictionary Dim arr, x arr = Range("a2:a12") For x = 1 To UBound(arr) d(arr(x, 1)) = "" Next x Range("c2").Resize(d.Count) = Application.Transpose(d.Keys) End Sub
    • 求和
      •  Sub 汇总() Dim d As New Dictionary Dim arr, x arr = Range("a2:b10") For x = 1 To UBound(arr) d(arr(x, 1)) = d(arr(x, 1)) + arr(x, 2) 'key对应的item的值在原来的基础上加新的 Next x Range("d2").Resize(d.Count) = Application.Transpose(d.Keys) Range("e2").Resize(d.Count) = Application.Transpose(d.Items) End Sub ‘ 多条件求和时key用字符把条件连接起来，输出时用split行数拆开 ’数据透视表汇总求和参考蓝色幻想的下棋法 VBA数组之下棋法.xls https://www.aliyundrive.com/s/7o1hjQHYVbs 提取码: 25zc
    • 查找
      •  Sub 多表双向查找() Dim d As New Dictionary Dim x, y Dim arr For x = 3 To 5 arr = Sheets(x).Range("a2").Resize(Sheets(x).Range("a65536").End(xlUp).Row - 1, 2) ’把每个表的学号和姓名放入数组 For y = 1 To UBound(arr) d(arr(y, 1)) = arr(y, 2)‘学号内放姓名 d(arr(y, 2)) = arr(y, 1)‘姓名内放学号 Next y Next x MsgBox d("C1") MsgBox d("吴情") End Sub
• 17. msgbox窗口
  • 一、什么MsgBox函数 它可以弹出一个窗口，显示你设定的内容。并且窗口上有可以让你选择的按钮，点击不同的按钮会返回不同的数值。 用msgbox信息窗口可以增加一个程序对话的机会，以告诉程序下一步应该怎么做 Sub test1() MsgBox "大家好，我是msgbox窗口" End Sub 二、基本语法 Msgbox (窗口中显示的内容,按钮和图示类别,窗口标题,相关的帮助文件,帮助文件上下文的编号)
  • 窗口和标题显示文字
    • 1、窗口显示的内容 1) 基本显示:只需要给第一个参数设置一个字符串或生成字符串的表达式即或 Sub test2() MsgBox "你好,欢迎你的使用" End Sub 2) 换行显示 'chr(10) 可以生成换行符 'chr(13) 可以生成回车符 'vbcrlf 换行符和回车符 'vbCr 等同于chr(10) 'vblf 等同于chr(13) Sub test3() MsgBox "我爱" & Chr(10) & "Excel精英培训" End Sub 3) 表格显示 'chr(9) 制表符 Sub test4() MsgBox "姓名" & Chr(9) & "职业" & Chr(10) & "张三" & Chr(9) & "工程师" & Chr(10) & "于上伟" & Chr(9) & "教师" End Sub ‘制表符设置 Sub test5() Dim sr, x, y For x = 1 To 5 For y = 1 To 3 sr = sr & Cells(x, y) & Chr(9) & Chr(9) ’一个不够可以加两个 Next y sr = sr & Chr(13) Next x MsgBox sr End Sub '用空格键设置 ' space(n) 可以产生N个空格 Sub test6()‘ Dim x, y, sr, k For x = 1 To 5 For y = 1 To 3 If VBA.IsNumeric(Cells(x, y)) Then k = 12 - Len(Cells(x, y)) Else k = 12 - Len(Cells(x, y)) * 2 End If sr = sr & Cells(x, y) & Space(k) Next y sr = sr & Chr(13) Next x MsgBox sr End Sub 2 标题的显示文字 Sub test7() MsgBox "核对关系出错了", , "系统提示" End Sub
  • 窗口的按钮类型和图标
    • 按钮类型 消息窗体由按钮显示,图标显示,缺省按钮和其他特殊功能组合,这些功能都可以随意组合,组合他们只需要用"+"号 Sub test8() MsgBox "test", vbYesNoCancel + vbExclamation + vbDefaultButton2 + vbMsgBoxHelpButton '显示test内容+警告图标+默认选中第二个按钮+帮助按钮添加 End Sub  要添加帮助,需要设置msgbox 函数的第四和第五个参数 '第四个参数是帮助文件的路径,帮助文件要放在C:\WINDOWS\Help路径下 '第五个参数和帮助文件本身有关,是为了准备的打开帮助文件而设置的上下文编号,如果没有则设置为0 Sub test13() Dim x Sub test13() Dim x MsgBox "测试添加帮助的效果", vbOKCancel + vbMsgBoxHelpButton, "测试帮助!", "D:/a.chm", 0 End Sub
  • 窗口返回值
    • 要想和消息框交流,还需要在我们点击窗体的按钮后能返回一个值,告诉程序我们点了哪个按钮. Sub test11() Dim k k = MsgBox("测试返回值", vbYesNoCancel) ’当需返回一个值时msgbox后需加（） MsgBox "你点击了按钮:" & Choose(k, "确定", "取消", "终止", "重试", "忽略", "是", "否") End Sub 'choose(1到29的数，arg1,arg2,...)1就返回arg1,2返回arg2 '应用示例 Sub test12() If MsgBox("你确定要删除第15行吗?", vbQuestion + vbYesNo, "删除提示") = vbYes Then Rows(15).Delete MsgBox "删除成功" Else MsgBox "你取消了删除" End If End Sub 返回值表，可以用场数也可以用数字 
  • 定时关闭窗口
    • 自动定时关闭消息框,可以用其他消息框完成 Sub AA() Dim WshShell As Object Set WshShell = CreateObject("Wscript.Shell") WshShell.Popup "1秒后关闭！", 1, "提示！", 16 ‘popup 显示文字，秒数，窗口标题，危险图标 End Sub
• 18. inputbox
  • 1.inpubox函数 语法: 'inputbox(输入框显示内容,窗体标题,默认值,水平位置,垂直位置,帮助文件,帮助文件ID 2.Application对象的Inputbox方法:显示一个接收用户输入的对话框。返回此对话框中输入的信息 语法: Application.InputBox(对话框显示内容,输入框标题,文本框内默认值,x坐标,y坐标,帮助文件,帮助文件上下文ID,文本框内输入类型) 最后一个参数数值说明: 值 含义 '0 公式 '1 数字 '2 文本 (字符串) '4 逻辑值 (True 或 False) '8 单元格引用，作为一个 Range 对象 '16 错误值，如 #N/A '64 数值数组 什么时候用方法,什么时候用函数 从上面的参数可以看出inputbox函数和方法的不同之处是方法比函数多了后面几个参不数,如果只是简单的输入,可以用方法, 如果需要添加帮助和设置输入类型,则用Application对象的Inputbox方法.
  • 基本应用
    • 1 输入的内容返回给一个变量‘当输入了值时两种用法无区别 Sub test1() Dim sr sr = InputBox("输入测试", "测试", 100) MsgBox sr sr = Application.InputBox("输入测试", "测试", 100) MsgBox sr End Sub 2 如果不输入直接点确定返回空 Sub test2() Dim sr sr = InputBox("输入测试", "测试") MsgBox sr sr = Application.InputBox("输入测试", "测试") MsgBox sr End Sub '经过测试发现当不输入任何内容直接点确定都会返回空,所以我们就可以用空来判断是否输入了内容 3 如果直接点了"退出"按钮会有什么值返回 Sub test4() Dim sr sr = InputBox("输入测试", "测试") MsgBox sr '返回空 sr = Application.InputBox("输入测试", "测试") MsgBox sr '返回False End Sub 由上面2,3可以看出,如果需要判断是否输入了内容和是否点击了退出,用Inpubox函数判断返回值是否为空就可以了, 如果是Inputbox方法,则需要进行两种判断.
  • 扩展应用
    • 最后一个参数数值说明: ' 值 含义 '0 公式 '1 数字 '2 文本 (字符串) '4 逻辑值 (True 或 False) '8 单元格引用，作为一个 Range 对象 '16 错误值，如 #N/A '64 数值数组 1.引用单元格 inputbox方法的最后个参数值为8的时候,可以用鼠标选择单元格的地址.使用变量是使用SET声明的对象变量,则返回的是一个单元格对象, 否则反回的这个单元格区域的值,即VBA数组. Sub text5() Dim rg As Range Set rg = Application.InputBox("请选择单元格区域", "选取提示", , , , , , 8) MsgBox rg.Parent.Name & "!" & rg.Address End Sub Sub text6() Dim rg rg = Application.InputBox("请选择单元格区域", "选取提示", , , , , , 8) MsgBox rg(2, 1) End Sub 2 公式引用 当最后一个参数设置为0时,可以输入公式,返回的也是一个公式字符串,如果公式中含单元格引用,可以自动转换成rc引用格式(以当前活动单元格为参照) Sub test7() Dim r r = Application.InputBox("请输入公式", "输入提示", , , , , , 0) MsgBox r End Sub 3 限制输入返回的数值格式 Sub test8() Dim r r = Application.InputBox("请输入公式", "输入提示", , , , , , 1) '输入非数字则会提示无效的数字 MsgBox r End Sub Sub test9() Dim r r = Application.InputBox("请输入公式", "输入提示", , , , , , 2) '可以输入字符,当然,文字型数字也符字符 MsgBox TypeName(r) End Sub 4.数值数组 可以选取单元格区域的值作为数组,也可以输入以带有大括号的一维或二维数组 Sub test10() Dim r r = Application.InputBox("请输入公式", "输入提示", , , , , , 64) '可以输入字符,当然,文字型数字也符字符 MsgBox r(2, 1) End Sub
• 19. excle对话框
  • GetOpenFilename
    • 一、 概述基本语法（返回文件名） GetOpenFilename相当于Excel打开窗口，通过该窗口选择要打开的文件，并可以返回选择的文件完整路径和文件名。 注:此方法并不会真正打开文件,会返回文件名 Application.GetOpenFilename(文件类型筛选规则,优先显示第几个类型的文件,标题,是否允许选择多个文件名) 二、示例 1 打开类型只限excel文件 '设置打开某类文件可以用下面的规则： '"文件类型说明文字,*.文件类型后辍" Sub t1() Dim f f = Application.GetOpenFilename("Excel文件,*.xls") MsgBox f End Sub 2、打开多种文件类型(word和excel) '打开多种文件类型，只需要用","隔开，添加新的文件类型说明和文件类型。 Sub t2() Dim f f = Application.GetOpenFilename("Excel2003文件,*.xls,Word文件,*.doc") MsgBox f End Sub 3 打开多种文件类型,默认显示word文件 Sub t3() Dim f f = Application.GetOpenFilename("Excel2003文件,*.xls,Word文件,*.doc,文本文件,*.txt", 2) MsgBox f End Sub 4 设置对话框名称 Sub t4() Dim f f = Application.GetOpenFilename("Excel2003文件,*.xls,Word文件,*.doc,文本文件,*.txt", 2, "选择要汇总的文件") MsgBox f End Sub 5 选择多个文件,并以数组形式返回 Sub t5() Dim f ChDrive "E" ’默认盘符设置 ChDir Application.Path ’默认文件夹设置 f = Application.GetOpenFilename("Excel2003文件,*.xls,Word文件,*.doc,文本文件,*.txt", 1, MultiSelect:=True) MsgBox f(1) ’返回起始编号为1的1维数组 End Sub
  • GetSaveAsFilename
    • GetSaveAsFilename语法: GetSaveAsFilename(默认显示的文件名,筛选条件,多个筛选类型时显示第几个,标题) '注:该窗口也会有实质性的保存操作.只作为返回文件名的一个途径 Sub t1() Dim f f = Application.GetSaveAsFilename("示例.xls", "excel表格,*.xls", , "保存示例") MsgBox f End Sub
  • FileDialog
    • 一 FileDialog 对象简介 提供文件对话框，功能与 Microsoft Office 应用程序中标准的“打开”和“保存”对话框类似。 利用这些对话框，解决方案的用户可以简便地指定解决方案中应该使用的文件和文件夹。 “打开”对话框：让用户选择一个或多个可以在主机应用程序中使用 Execute 方法打开的文件。 “另存为”对话框：让用户选择一个可以使用 Execute 方法保存当前文件的文件。 “文件选取器”对话框：让用户选择一个或多个文件。用户选择的文件路径将捕获到 FileDialogSelectedItems 集合。 “文件夹选取器”对话框：让用户选择一个路径。用户选择的文件路径将捕获到 FileDialogSelectedItems 集合。 二 属性和方法  1. AllowMultiSelect ：允许用户从文件对话框中选择多个文件，填写 True。 2. Filters.Add 规则名称, 过滤文件类型, 规则起始位置（初始为1） ：添加过滤规则 3.SelectedItems ：选取的多个文件集合 4.InitialFileName ：设置初始路径和文件名称 5.InitialView ：可以设置初始文件的显示样式（文件查看类型） 6.Title ：对话框标题 7.show ：可以判断用户是否点击了取消按钮,如果点击取消会返回0,否则返回-1 8.ilters.Clear ：清除当前的过滤规则 9.ButtonName ：选择按键名称 '选择并返回一组文件名和路径 Sub f1() Dim f Dim dig As Object Set dig = Application.FileDialog(msoFileDialogOpen) With Application.FileDialog(msoFileDialogOpen) .AllowMultiSelect = True '允许选择多个文件 .Filters.Add "Excel文件", "*.xls", 1 '过滤规则为把后缀为.xls的Excel文件筛选出来 .InitialFileName = ThisWorkbook.FullName '"d:\" '初始路径和文件名称为当前文件名及其路径 .InitialView = msoFileDialogViewDetails '初始文件的显示样式：详细信息 .Title = "对话框测试" '对话框标题：对话框测试 .Show '把文件名和路径放在selecteditem属性里，通过序号或者循环一一读取 MsgBox .Show For Each f In .SelectedItems '返回的文件 MsgBox f Next f End With Set dig = Nothing End Sub '选择并返回文件夹 Sub F2() Dim dig As Object Set dig = Application.FileDialog(msoFileDialogFolderPicker) With dig .InitialFileName = "d:\" .Show MsgBox .SelectedItems(1) End With Set dig = Nothing End Sub
• 20. 字符串处理
  • 字符串拆分
    • 字符串截取 Sub z1() Dim sr sr = "Excel精英培训网" Debug.Print Left(sr, 5) ‘从左边起截取5个字符 返回 Excel Debug.Print Right(sr, 5) ‘从右边起截取5个字符 返回 精英培训网 Debug.Print Mid(sr, 3, 5) ‘从第3位起向右截取5个字符 返回 cel精英 Debug.Print Left(sr, Len(sr) - 1) End Sub Sub z2() Dim sr, arr sr = "Excel-精英-培训网" arr = Split(sr, "-") ‘把sr根据"-"字符拆分 Debug.Print arr(1) ’返回精英 ：split拆分后返回下标位0的一维数组 Debug.Print UBound(arr) ‘可利用下标来判断是否存在某字符 End Sub Sub z3() Dim sr sr = "89.90美元" Debug.Print Val(sr) '返回89.90 ;单首字符为数字时可返回数字，首字符为其他返回0 End Sub sr = "a89.90美元" val函数返回0 sr = "89a.90美元" val函数返回89
  • 字符串组合
    • Sub a4() Debug.Print "a" & "b" End Sub Sub a5() Dim sr, arr sr = "Excel-精英-培训网" arr = Split(sr, "-") Debug.Print Join(arr, "+") 把arr以"+"连接起来，返回 Excel+精英+培训网 End Sub
  • 字符串查找
    • Sub c1() Dim sr sr = "Excel精英培训" Debug.Print InStr(sr, "精英") '从前向后查找"精英"的字符串位置，返回6 ，不存在返回0 End Sub ‘可利用返回值判断是否存在某字符 Sub c2() Dim sr sr = "Excel精英培训培训论坛" Debug.Print InStrRev(sr, "培") ’从后面往前查找第一个"培"的字符串位置，返回8 End Sub
  • 字符串替换
    • Sub c5() Dim sr sr = "Excel精英培训网" sr = Replace(sr, "培训网", "论坛") ‘返回 Excel精英论坛 Debug.Print sr End Sub Sub c6() Dim sr sr = "Excel精英培训网" Mid(sr, 8, 3) = "论坛" ‘返回 Excel精英论坛网 Debug.Print sr End Sub
  • 字符串转换
    • Sub z1() Debug.Print LCase("ABC") 'LCase 转换成小写 返回 abc End Sub Sub z2() Debug.Print UCase("Abc") 'UCcae 转换成大写 返回 ABC End Sub 'StrConv 函数 常数 值 说明 'vbUpperCase 1 将字符串文字转成大写。 'vbLowerCase 2 将字符串文字转成小写。 'vbProperCase 3 将字符串中每个字的开头字母转成大写 Sub 转换1() Debug.Print VBA.StrConv("wHo ARE you?", vbProperCase) ’返回Who Are You? End Sub Sub 转换2() Dim i As Long Dim x() As Byte x = StrConv("ABCDEFG", vbFromUnicode) ' 转换字符串 返回0下标的一维数组 Debug.Print Application.Min(x) ‘打印一维数组里的最小值 For i = 0 To UBound(x) Debug.Print x(i) Next End Sub Sub z3() Dim sr sr = " A B BC " Debug.Print Trim(sr) 'TRim删除两端空格 返回 “A B BC” Debug.Print LTrim(sr) 'Ltrim 删除左边空格 返回 “A B BC ” Debug.Print RTrim(sr) 'Rtrim 删除右边空格 返回 “ A B BC” End Sub 'ASC 返回一个 Integer，代表字符串中首字母的字符代码,ANSI 字符集 'CHr 返回 String，其中包含有与指定的字符代码相关的字符 Sub z4() Debug.Print Asc("Z") ’ASC 返回一个 Integer，代表字符串中首字母的字符代码,ANSI 字符集 Debug.Print Chr(90) ' CHr 返回 String，其中包含有与指定的字符代码相关的字符 End Sub‘列转换 Sub z5() Debug.Print "A" & Space(10) & "B" ’生成10个空格 A B Debug.Print "C" & String(10, "a") & "D" '生成10个a CaaaaaaaaaaD End Sub
• 21. 正则表达式
  • 概念属性方法
    • 一 正则表达式 正则表达式是处理字符串的外部工具，它可以根据设置的字符串对比规则，进行字符串的对比、替换等操作。 正则表达式的作用： 1、完成复杂的字符串判断 2、在字符串判断时，可以最大限度的避开循环，从而达到提高运行效率的目的。 二 使用方法 1、引用法 点击VBE编辑器菜单：工具 - 引用，选取: Microsoft VBScript Regular Expressions 5.5,引用后在程序开始进行如下声明 Sub t1() Dim reg As New RegExp End Sub 2、直接他建法 代码引用 (后期绑定) Sub t2() Dim reg As Object Set reg = CreateObject("VBScript.RegExp") End Sub 三 常用属性 1 Global属性: 如果值为true,则搜索全部字符 如果值为False,则搜索到第1个即停止 例: Sub t3() Dim reg As New RegExp Dim sr sr = "ABCEA" With reg .Global = True .Pattern = "A" Debug.Print .Replace(sr, "") End With End Sub 2 IgnoreCase 属性 如果搜索是区分大小写的，为False（缺省值）True不分 3 Pattern 属性 一个字符串，用来定义正则表达式。缺省值为空文本。 4 Multiline 属性 字符串是不是使用了多行,如果是多行,$适用于每一行的最后一个 Sub t4() Dim reg As New RegExp Dim sr sr = "AEA" & Chr(10) & "ABCA" With reg .Global = True .MultiLine = True .Pattern = "A$" .Pattern = "^A" Debug.Print .Replace(sr, "") End With End Sub 5 Execute 方法 返回一个 MatchCollection 对象，该对象包含每个成功匹配的 Match 对象, 返回的信息包括: 'FirstIndex:开始位置 'Length; 长度 'Value:长度 Sub t5() Dim reg As New RegExp Dim sr, matc sr = "A454BCEA5" With reg .Global = True .Pattern = "A\d+" Set matc = .Execute(sr) End With Stop End Sub Function ns(rg) Dim reg As New RegExp Dim sr, ma, s, m, x With reg .Global = True .Pattern = "\d*\.?\d*" Set ma = .Execute(rg) For Each m In ma s = s + Val(m) Next m End With ns = s ' Stop End Function 6、Text方法 返回一个布尔值，该值指示正则表达式是否与字符串成功匹配。其实就是判断两个字符串是否匹配成功 Sub t7() Dim reg As New RegExp Dim sr sr = "BCR6EA" With reg .Global = True .Pattern = "\d+" If .test(sr) Then MsgBox "字符串中含有数字" End With End Sub
  • 常用符号
    • \号 1.放在不便书写的字符前面,如换行符(\r),回车符(\n),制表符(\t),\自身(\\) 2.放在有特殊意义字符的前面,表示它自身,"\$","\^","\." 3.放在可以匹配多个字符的前面 \d 0~9的数字 \w 任意一个字母或数字或下划线，也就是 A~Z,a~z,0~9,_ 中任意一个 \s 包括空格、制表符、换页符等空白字符的其中任意一个 以上改为大写时,为相反的意思,如\D 表示非数字类型 Sub t1() Dim regx As New RegExp Dim sr sr = "AE45B646C" With regx .Global = True .Pattern = "\d" '排除非数字 返回AEBC Debug.Print .Replace(sr, "") End With End Sub .(点) 可以匹配除换行符以外的所有字符 +号 +表示一个字符可以有任意多个重复的。 Sub t11() Dim regx As New RegExp Dim sr sr = "A234CA7A" With regx .Global = True .Pattern = "A\d+" ' 返回CA Debug.Print .Replace(sr, "") End With End Sub {}号 可以设置重复次数 ‘1 {n} 重复n次 Sub t16() Dim regx As New RegExp Dim sr sr = "A234CA7A67" With regx .Global = True .Pattern = "\d{2}" '连续两个数字 返回 A4CA7A Debug.Print .Replace(sr, "") End With End Sub 2 {m,n} 最小重复m次,最多重复n次 Sub t22() Dim regx As New RegExp Dim sr sr = "A234CA7A6789" With regx .Global = True .Pattern = "\d{2,3}" '连续两个数字或连续三个数字 返回 ACA7A9 Debug.Print .Replace(sr, "") End With End Sub 3 {m,} 最少重复m次,相当于+ Sub t23() Dim regx As New RegExp Dim sr sr = "A2348t6CA7A67" With regx .Global = True .Pattern = "\d{2,}" '连续两个数字或两个以上数字 返回 At6CA7A Debug.Print .Replace(sr, "") End With End Sub * 号 可以出现0等任意次 相当于 {0,}，比如："\^*b"可以匹配 "b","^^^b"... ?号 匹配表达式0次或者1次，相当于 {0,1}，比如："a[cd]?"可以匹配 "a","ac","ad" Sub t24() Dim regx As New RegExp Dim sr sr = "A23.48CA7A6..7" With regx .Global = True .Pattern = "\d+\.?\d+" '最多连续1个 返回 ACA7A6..7 Debug.Print .Replace(sr, "") End With End Sub 2 利用+?的格式可以分段匹配 Sub t87() Dim regex As New RegExp Dim sr, mat, m sr = "<td><p>aa</p></td> <td><p>bb</p></td>" With regex .Global = True .Pattern = "<td>.*?</td>" 除换行符外的任意字符出现无数个的情况出现0次或1次 Set mat = .Execute(sr) For Each m In mat Debug.Print m 返回<td><p>aa</p></td> 和 <td><p>bb</p></td> Next m End With End Sub Sub t88() Dim regex As New RegExp Dim sr, mat, m sr = " aba aca ada " With regex .Global = True .Pattern = "\s.+?\s" 空格加除换行符以外的任意字符出现无数个的情况出现0次或1次再加空格 Set mat = .Execute(sr) For Each m In mat Debug.Print m Next m End With End Sub 返回： aba aca ada
  • 中括号的作用
    • [] 使用方括号 [ ] 包含一系列字符，能够匹配其中任意一个字符。用 [^ ] 则能够匹配其中字符之外的任意一个字符。同样的道理，虽然可以匹配其中任意一个，但是只能是一个，不是多个 1 和括号内的其中一个匹配 Sub t29() Dim regx As New RegExp Dim sr sr = "ABDC" With regx .Global = True .Pattern = "[BC]" 匹配B或者匹配C 返回AD Debug.Print .Replace(sr, "") End With End Sub 2 非括号内的字符 Sub T35() Dim regx As New RegExp Dim sr sr = "ABCDBDC" With regx .Global = True .Pattern = "[^BC]" 匹配非B或非C的字符 返回BCBC Debug.Print .Replace(sr, "") End With End Sub 3 在一个区间 Sub t38() Dim regx As New RegExp Dim sr sr = "ABCDGWDFUFE" With regx .Global = True .Pattern = "[A-H]" 匹配A到H间的字符 返回 WU Debug.Print .Replace(sr, "") End With End Sub Sub t40() Dim regx As New RegExp Dim sr sr = "124325436789" With regx .Global = True .Pattern = "[1-47-9]" 匹配1到4和7到9的字符 返回 56 Debug.Print .Replace(sr, "") End With End Sub
  • 小括号的作用
    • () 可以让括号内作为一个整体产生重复 Sub t29() Dim regx As New RegExp Dim sr sr = "A3A3QA3A37BDFE87A8" With regx .Global = True .Pattern = "((A3){2})" '相当于A3A3 返回Q7BDFE87A8 Debug.Print .Replace(sr, "") End With End Sub 取匹配结果的时候，括号中的表达式可以用 \数字引用 引用时采取从左往右，从外向里排序 Sub t30() Dim regx As New RegExp Dim sr sr = "A3A3QA3A37BDFE87A8" With regx .Global = True .Pattern = "((A3){2})Q\1" \1相当于 "((A3){2})Q((A3){2})" 返回7BDFE87A8 Debug.Print .Replace(sr, "") End With End Sub Sub t31() Dim regx As New RegExp Dim sr sr = "A3A3B4B4QB4B47BDFE87A8" With regx .Global = True .Pattern = "((A3){2})((B4){2})Q\4" \4相当于"((A3){2})((B4){2})Q（B4) 返回B47BDFE87A8 \1=((A3){2}) \2=(A3) \3=((B4){2}) Debug.Print .Replace(sr, "") End With End Sub 用(?=字符)可以先进行预测查找，到一个匹配项后，将在匹配文本之前开始搜索下一个匹配项。 不会保存匹配项以备将来之用。 例：截取某个字符之前的数据 Sub t343() Dim regex As New RegExp Dim sr, mat, m sr = "100元8000元57元" With regex .Global = True .Pattern = "\d+(?=元)" '查找任意多数字后的元，查找到后从元以前开始查找（因为元前的数字已被使用， '所以只能从元开始查找）匹配 ()后面的，因为后面没有设置，所以只显示前面的数字，元不再显示 返回{100,800,57}，若要后面带元字则加点"\d+(?=元)." Set mat = .Execute(sr) For Each m In mat Debug.Print m Next m End With End Sub 例：验证密码，条件是4-8位，必须包含一个数字 “^ $” Sub t355() Dim regex As New RegExp Dim sr, mat, m sr = "A8ayaa" With regex .Global = True .Pattern = "^(?=.*\d).{4,8}$" “^.{4,8} $" 限制字符串长度 (?=.*\d) 表示任意多个字符带数字 Set mat = .Execute(sr) For Each m In mat Debug.Print m 返回 A8ayaa Next m End With End Sub 用(?!字符)可以先进行负预测查找，到一个匹配项后，将在匹配文本之前开始搜索下一个匹配项。 不会保存匹配项以备将来之用。 Sub t356() Dim regex As New RegExp Dim sr, mat, m sr = "中国建筑集团公司" With regex .Global = True .Pattern = "^(?!中国).*" 不返回值，因为开头包含中国 Set mat = .Execute(sr) For Each m In mat Debug.Print m Next m End With End Sub ()与|一起使用可以表示or Sub t344() Dim regex As New RegExp Dim sr, mat, m sr = "100元800块7元" With regex .Global = True .Pattern = "\d+(元|块)" 利用()与| 简写 '.Pattern = "\d+(?=元|块)" .Pattern = "\d+元|\d+块" 正常写法 Set mat = .Execute(sr) For Each m In mat Debug.Print m Next m End With End Sub
  • 其他符号
    • ^符号：限制的字符在最前面,如^\d表示以数字开头 Sub T34() Dim regex As New RegExp Dim sr, mat, m sr = "234我345d43" With regex .Global = True .Pattern = "^\d*" 开头数字 返回234 Set mat = .Execute(sr) For Each m In mat Debug.Print m Next m End With End Sub $符号：限制的字符在最后面，如 A$表示最后一个字符是A Sub T3433() Dim regex As New RegExp Dim sr, mat, m sr = "R243r" With regex .Global = True .Pattern = "^\D.*\D$" 开头非数字结尾非数字 Set mat = .Execute(sr) For Each m In mat Debug.Print m Next m End With End Sub \b 空格(包含开头和结尾) Sub t26() Dim regx As New RegExp Dim sr sr = "A12dA56 A4" With regx .Global = True .Pattern = "\bA\d+" Debug.Print .Replace(sr, "") End With End Sub Sub T272() Dim regex As New RegExp Dim sr, mat, m sr = "ad bf cr de ee" With regex .Global = True .Pattern = ".+?\b" 除换行符外的任意字符出现多个加空格 Set mat = .Execute(sr) For Each m In mat If m <> " " Then Debug.Print m Next m End With End Sub | 可以设置两个条件,匹配左边或右边的 Sub t27() Dim regx As New RegExp Dim sr sr = "A12DA56 A4B34D" With regx .Global = True .Pattern = "A\d+|B\d+" 符合左边的A加任意数字或后边的B加任意数字 Debug.Print .Replace(sr, "") End With End Sub \un 匹配 n，其中 n 是以四位十六进制数表示的 Unicode 字符。 汉字一的编码是4e00,最后一个代码是9fa5 Sub t2722() Dim regx As New RegExp Dim sr sr = "A12d我A爱56你 A4" With regx .Global = True .Pattern = "[\u4e00-\u9fa5]" ‘匹配汉字 Debug.Print .Replace(sr, "") End With End Sub
  • 练习与汇总
    • 
• 22. 数据类型及转换
  • 数据类型
    • 1 数据类型综述 在VBA中的数据类型有整数、文本、对象等类型。这些不同的类型有着特定的作用，在进行运算时也会占用 不同大小的内存，所以我们在编写程序时为了提高运行效率，一般都要定义数据的类型。 2 数据类型对程序运行的影响 'byte 占用1个字节 'integer,boolean 占用2个字节 'long,single 占用4个字节 'Double,Currency,date 占用8个字节 'object 占用4个字节 'string(不定长) 占用10+字符长度个字节 'String(定长) 占用字符串长度个字节 'Variant(任意数字类型) 占用16个字节 'Variant(字符串) 占用24+字符串长度个字节 占用字节越多运行事件越长
  • 数据类型检查
    • 1 检查是否为空 Sub s1() Debug.Print Range("a1") = "" '判断真空,无法判断假空 Debug.Print Len(Range("a1")) = 0 '判断真空，无法判断假空 Debug.Print VBA.IsEmpty(Range("a1")) '假空时返回FALSE Debug.Print VBA.TypeName(Range("a1").Value) '返回Empty表示为空 End Sub 2 检查是否为数字 Sub s2() Debug.Print VBA.IsNumeric(Range("a1")) Debug.Print Application.WorksheetFunction.IsNumber(Range("A1")) Debug.Print VBA.TypeName(Range("A1").Value) ' Debug.Print Range("a1").Value Like "#" '判断一位整数 ' Debug.Print Range("a1") Like "*#*" '判断是否包含数字 End Sub 3 检查是否为文本 Sub t3() Debug.Print Application.IsText(Range("a1")) Debug.Print "B" Like "[A-Za-z]" '判断是否为字母 Debug.Print Len(Range("a1")) Debug.Print Range("a1") Like "*[一－龥]*" '判断字符串中是否包含汉字 End Sub 4 判断结果是否为错误值 Sub s4() Debug.Print VBA.IsError(Range("a1")) Debug.Print TypeName(Range("a1").Value) End Sub 5 判断是否为数组 Sub s5() Dim arr arr = Range("A1:A2") Erase arr Debug.Print VBA.IsArray(arr) End Sub 6 判断是否为日期 Sub s6() Debug.Print VBA.IsDate(Range("a2")) End Sub
  • 数据类型转换
    • 一、类型转换函数： CBool, CByte, CCur, CDate, CDbl, CDec, CInt, CLng, CSng, CStr, CVar 上述函数是把表达式转换成相对应的数字类型，比如clng转换成长整型,cstr转换成文本型 Sub ss1() Dim s As Integer s = 2334 MsgBox 截取(CStr(s)) '因为自定义函数参数要求是文本类型，而s是数值类型，所以需要用cstr转换成文本类型 End Sub Function 截取(x As String) 截取 = Left(x, 2) End Function Sub ss2() Debug.Print 1 + True 'CInt(1 = 1) End Sub 二、Format函数 format函数用法等同于工作表中的text函数，可以格式化显示数字或文本 Sub ss3() Dim n, n1 n = 234.3372 n1 = 41105 Debug.Print Format(n, "0.00") Debug.Print Format(n, "0") Debug.Print Format(n, "\价格\:0.00") Debug.Print Format(n1, "yyyy-mm-dd") End Sub
  • 日期与时间
    • 日期返回
      • 1 返回当前日期、时间（指本机系统设置的日期和时间） Sub t1() Debug.Print Date '返回当前日期 2022/6/15 Debug.Print Time '返回当前时间 9:58:24 Debug.Print Now '返回当前日期+时间2022/6/15 9:58:24 End Sub 2 格式化显示日期 Sub t2() Debug.Print Format(Now, "yyyy-mm-dd") 2023-03-15 Debug.Print Format(Now, "yyyy年mm月dd日") 2023年03月15日 Debug.Print Format(Now, "yyyy年mm月dd日 h:mm:ss") 2023年03月15日 9:59:39 Debug.Print Format(Now, "d-mmm-yy") '英文月份 15-Mar-23 Debug.Print Format(Now, "d-mmmm-yy") '英文月份 15-March-23 Debug.Print Format(Now, "aaaa") '中文星期 星期三 Debug.Print Format(Now, "ddd") '英文星期前三个字母 Wed Debug.Print Format(Now, "dddd") '英文星期完整显示 Wednesday End Sub 3 根据年月日返回日期 Sub t3() Debug.Print VBA.DateSerial(2011, 10, 1) 2011/10/1 End Sub 4 根据小时分种返回时间 Sub t4() Debug.Print VBA.TimeSerial(1, 2, 1) 1:02:01 End Sub 5 返回年月日小时分秒 Sub t5() Dim d d = "2011-10-28 01:10:03" Debug.Print Year(d) & "年" 2011年 Debug.Print Month(d) & "月" 10月 Debug.Print Day(d) & "日" 28日 Debug.Print Hour(d) & "时" 1时 Debug.Print Minute(d) & "分" 10分 Debug.Print Second(d) & "秒" 3秒 End Sub
    • 日期与时间计算
      • 1 计算两个日期相隔天数,月数,年数,小时,分种,秒 Sub tt1() Dim d1, d2 As Date d1 = #11/21/2011# d2 = #12/1/2011# Debug.Print "相隔" & (d2 - d1) & "天" 相隔10天 Debug.Print "相隔" & DateDiff("d", d1, d2) & "天" 相隔10天 Debug.Print "相隔" & DateDiff("m", d1, d2) & "月" 相隔1月 Debug.Print "相隔" & DateDiff("yyyy", d1, d2) & "年" 相隔0年 Debug.Print "相隔" & DateDiff("q", d1, d2) & "季" 相隔0季 Debug.Print "相隔" & DateDiff("w", d1, d2) & "周" 相隔1周 Debug.Print "相隔" & DateDiff("h", d1, d2) & "小时" 相隔240小时 Debug.Print "相隔" & DateDiff("n", d1, d2) & "分种" 相隔14400分种 Debug.Print "相隔" & DateDiff("s", d1, d2) & "秒" 相隔864000秒 End Sub Sub tt2() '计算两时间的差 Dim t, x t = Timer For x = 1 To 10000000 Next x Debug.Print Timer - t End Sub 2 日期时间加减 Sub tt3() Dim d1, d2 As Date d1 = "2001-10-1 00:00:00" Debug.Print VBA.DateAdd("d", 10, d1) '加上10天 Debug.Print VBA.DateAdd("m", 10, d1) '加上10个月 Debug.Print VBA.DateAdd("yyyy", 10, d1) '加上10年 Debug.Print VBA.DateAdd("yyyy", -10, d1) '减少10年 Debug.Print VBA.DateAdd("h", 10, d1) '加上10小时后的时间 Debug.Print VBA.DateAdd("n", 10, d1) '加上10分种后的时间 Debug.Print VBA.DateAdd("s", 10, d1) '加上10秒后的时间 End Sub
    • 时钟计时器
      • Option Explicit Dim k Sub ttt1() Application.OnTime TimeValue("15:46:00"), "A" 15:46:00运行A程序 End Sub Sub A() MsgBox "test" End Sub Sub ttt2() Application.OnTime Now + TimeValue("00:00:20"), "A" 现在的时间+20秒运行程序A End Sub Sub 时间显示() 时间显示 Dim x If k = 1 Then k = 0 End End If 通过外部变量K来终止调用时间显示 Range("a1") = Format(Now, "yyyy-mm-dd") & Format(Now, "h:mm:ss") Application.OnTime Now + TimeValue("00:00:01"), "时间显示" 一秒后调用自己，实现时间显示 x = DoEvents 必要语句，当时间显示调用时还能运行其他程序 End Sub Sub 结束时间显示() 当运行该程序时，时间显示终止 k = 1 End Sub
• 23. 图片与图形处理
  • shape对象
    • Shape 对象，该对象代表工作表或图形工作表上的所有图形，它是sheets和chart的子对象（属性）。 Name shape的名字 Type shape的类型 BottommRightCell shape 右下角的单元格，可用于定位shape的位置 TopLeftCell shape 左上角的单元格，可用于定位shape的位置 Hyperlink shape所带的超链接 Visible Shape是否可见 OnAction shape带的指定宏 Top,Width,Height,Lefft shape的顶点，宽度，高度，左边距，这四个属性确定shape的大小
  • shape的类型
  • 例子
    •  Sub 图片导入() Dim S As Shape Dim RG As Range '删除已有图片 For Each S In ActiveSheet.Shapes If S.Type <> 8 Then '有插入一个窗体控件指定宏 S.Delete '把不是窗体控件的shape（图片、图形等）清除 End If Next S '导入图形 For Each RG In Range("B2:B5") '插入矩形msoShapeRectangle，它的左边距、顶点、宽度、高度都引用RG单元格的 ActiveSheet.Shapes.AddShape(msoShapeRectangle, RG.Left, RG.Top, RG.Width, RG.Height).Select 'RG单元格左边单元格填写了图片名称，填充对应图片到矩形里。 Selection.ShapeRange.Fill.UserPicture "C:\" & RG.Offset(0, -1) & ".jpg" Next RG End Sub '可以用宏录制不会的代码  Sub 批量插入复选框() Dim RG As Range Dim S As Shape '删除已有复选框 For Each S In ActiveSheet.Shapes If InStr(S.Name, "Ch") > 0 Then '复选框的名称是Check box S.Delete End If Next S '批量插入复选框 For Each RG In Range("B2:B15") '插入复选框CheckBoxes，它的左边距、顶点、宽度、高度都引用RG单元格的 ActiveSheet.CheckBoxes.Add(RG.Left, RG.Top, RG.Width, RG.Height).Select '复选框的文本为“是”,值为空，链接的单元格是RG的位置 With Selection .Characters.Text = "是" .Value = xlOff .LinkedCell = RG.Address End With '把RG单元格的字体颜色变成白色，否则打勾会显示True和False RG.Font.ThemeColor = xlThemeColorDark1 Next RG End Sub
• 24. 随机抽取
  • 字典法
    •  Sub 随机抽取() '字典法 Dim dic, i, j, k j = Timer Dim arr, arr1(1 To 20000, 1 To 1) As String Set dic = CreateObject("scripting.dictionary") arr = Range("a1:a20000") For i = 1 To 20000 100: k = Rnd() * (20000 - 1) + 1 If dic.exists(k) Then GoTo 100 Else dic("k") = "" arr1(i, 1) = arr(k, 1) End If Next Range("c1:c20000").Clear Range("c1:c20000") = arr1 [d65536].End(xlUp).Offset(1, 0) = Timer - j End Sub
  • 移形换位法
    • Sub 移形随机排序() Dim arr Dim arr1(1 To 20000, 1 To 1) As String, sr As String Dim x As Integer, num, t t = Timer arr = Range("a1:a20000") For x = 1 To UBound(arr) num = (Rnd() * ((20000 - x + 1) - 1) + 1) \ 1 '\ 整除相当于int arr1(x, 1) = arr(num, 1) '换位 sr = arr(num, 1) arr(num, 1) = arr(20000 - x + 1, 1) arr(20000 - x + 1, 1) = sr Next x Range("c1:c20000") = "" Range("c1:c20000") = arr1 [d65536].End(xlUp).Offset(1, 0) = Timer - t End Sub Sub 移形随机排序升级() Dim arr Dim arr1(1 To 20000, 1 To 1) As String, sr As Integer Dim x As Integer, num, t, y Dim arr2(1 To 20000) t = Timer arr = Range("a1:a20000") For y = 1 To 20000 arr2(y) = y Next y For x = 1 To UBound(arr) num = (Rnd() * ((20000 - x + 1) - 1) + 1) \ 1 arr1(x, 1) = arr(arr2(num), 1) '换位 sr = arr2(num) arr2(num) = arr2(20000 - x + 1) arr2(20000 - x + 1) = num Next x Range("c1:c20000") = "" Range("c1:c20000") = arr1 [F65536].End(xlUp).Offset(1, 0) = Timer - t End Sub
• 25. 程序加速
  • 减少对象调用
    • 调用对象是非常非常的耗费资源的，所以一定要尽可能的少调用对象。包括： 工作簿、工作表、单元格以及外引用对象。 Sub 在循环中调用单元格() Dim x As Integer, k Dim t t = Timer For x = 1 To 20000 k = [a1] Next x Debug.Print Timer - t End Sub Sub 在循环外调用单元格() Dim x As Long, k, m Dim t t = Timer m = [a1] For x = 1 To 2000000 k = m Next x Debug.Print Timer - t End Sub '上面两个程序运行的结果一样，但速度却差了 28.12/0.03=937倍
  • 减少计算次数
    • '程序的运算速度和计算次数有着很大的关系，所以要尽可能的减少计算的次数 '能在循环外计算出结果的，就不要在循环内计算。 Sub 在循环中计算() Dim a, b, c, x, t, k t = Timer a = 100: b = 2: c = 3 For x = 1 To 1000000 k = a ^ b + c Next x Debug.Print Timer - t End Sub Sub 在循环外计算() Dim a, b, c, x, t, k, m t = Timer a = 100: b = 2: c = 3 m = a ^ b + c For x = 1 To 1000000 k = m Next x Debug.Print Timer - t End Sub
  • 禁止闪屏
    • 'Application.ScreenUpdating当设置属性值为false时，可以禁止程序运行过程中的屏幕闪动 '进而提高运行速度 '注意：只有对会引起闲屏操作的代码才有效，否则可能还会拖慢程序的速度 Sub 没有禁闪屏() Dim x, t t = Timer For x = 1 To 100 Sheets(2).Select Next x [a1] = Timer - t End Sub Sub 禁闪屏() Dim x, t t = Timer Application.ScreenUpdating = False For x = 1 To 100 Sheets(2).Select Next x [b1] = Timer - t Application.ScreenUpdating = True End Sub
  • 增加变量的声明类型
  • 减少工作表函数的调用
  • 用静态数组替换动态数组
  • 填充时先清空单元格
  • 批量代替个体
  • 减少循环次数
  • 巧妙填充公式
    • '向单元格输入公式,如果是连续的,就可以用填充的方法来完成. Sub 填充公式方法1() Dim x, t t = Timer Range("e2:e1000") = "" For x = 2 To 1000 Cells(x, "e") = "=C" & x & "*D" & x Next x Debug.Print Timer - t End Sub Sub 填充公式方法2() Dim x, t Range("e2:e2000") = "" t = Timer Cells(2, "e") = "=C2*D2" Range("e2:e2000").FillDown Debug.Print Timer - t End Sub
• 26. 文件操作
  • TXT文件读写
    • txt文件的读写方法
      • Open 文件名 for 打开方式 as 文件编号 打开方式: Input ：只能读，不能写 Append：允许读也允许写，如果存在文件就追加记录，如果没有就新建文件 Output：可以读，也可以写。但总会把原来的同名文件删除，再新建一个 读取txt文件内容方法 input：从文件中读取指定数量的字符。 Input #：把数据读出放在变量里，变量用逗号分隔 Line Input #：取出完整的一行 向文件中写入数据 write #：向文件中写入值，值用引号引起来。如果想在同一行中继续写入，可以在前一次写时结尾添加“;”号 Print #：向文件中写入值，如果想在同一行中继续写入，可以在前一次写时结尾添加“;” 字符的间隔符 Spc(n)表示输入n个空字符
    • 写入
      • 一、用Print写入 1 分行输入 Sub t1() Dim f As String f = ThisWorkbook.path & "\a.txt" Open f For Output As #1 Print #1, "产品名称" 产品名称 Print #1, Date date 分行输入 Print #1, "产品名称"; 产品名称A产品 接上一行输入 Print #1, "A产品" Close #1 End Sub 3 输入时添加空格符 Sub t3() Dim f As String f = ThisWorkbook.path & "\a.txt" Open f For Output As #1 Print #1, "产品名称"; Spc(5); Print #1, "A产品" Close #1 End Sub 4 在指定的列数输入 Sub t4() Dim f As String f = ThisWorkbook.path & "\a.txt" Open f For Output As #1 Print #1, "产品名称"; Tab(8); '在第10列输入下面的，如果为空则插入到下一个打印的位置 Print #1, "A产品" Close #1 End Sub 二、用Write写入 Sub t5() Dim f As String f = ThisWorkbook.path & "\a.txt" Open f For Output As #1 Write #1, "产品名称" Write #1, 5 "产品名称" Close #1 5 End Sub Sub t6() Dim f As String f = ThisWorkbook.path & "\a.txt" Open f For Output As #1 Write #1, "产品名称"; Write #1, 5 "产品名称",5 Close #1 End Sub Sub t7() Dim f As String f = ThisWorkbook.path & "\a.txt" Open f For Output As #1 Write #1, "产品名称"; 5 '这里逗号等同于"; "(分号)" "产品名称",5 Close #1 End Sub 三、Print和Write区别 1 写入到txt文件后，字符会添加“,”(逗号) 2 除文本外，日期、逻辑值输入结果不一样,两边会加#号 Sub t8() Dim f As String f = ThisWorkbook.path & "\a.txt" Open f For Output As #1 Print #1, Date; 1 = 1; Null 2021-1-1TrueNull Write #1, Date; 1 = 1, Null # 2021-1-1#,#True#,#Null# Close #1 End Sub 四 不同类型数值的输入的 在用print写入数据时 '1 日期后要加空格 '2 数字前后都加空格 '3 字符前后均不加空格 Sub t9() Dim f As String f = ThisWorkbook.path & "\a.txt" Open f For Output As #1 Print #1, Date; 12 Print #1, Date; "ABC" Print #1, Date; "我爱你" Print #1, Date; Date Print #1, "我爱你"; 12 Print #1, "我爱你"; "abc" Print #1, "我爱你"; Date Print #1, "我爱你"; "abc" Print #1, 12; "abc" Print #1, 12; "我爱你" Print #1, 12; 123 Print #1, 12; "123" Close #1 End Sub 
    • 读取方法：open
      • 1、input函数读取 Input 函数只用于以 Input 或 Binary 方式打开的文件 Input 函数返回它所读出的所有字符，包括逗号、回车符、空白列、换行符、引号和前导空格等 Sub d1() On Error Resume Next Dim f, mychar f = ThisWorkbook.path & "/a.txt" Open f For Input As #1 Do While Not EOF(1) ' 循环至文件尾。 mychar = Input(3, #1) ' 读入一个字符。 Debug.Print mychar ' 显示到立即窗口。 Loop Close #1 End Sub Sub d2() '把文本文件的内容一次性取出来 Dim f, mychar, n, L f = ThisWorkbook.path & "/a.txt" n = FreeFile Open f For Input As n L = LOF(n) mychar = Input(L - 6, n) '要减去中文字符的个数 Debug.Print mychar ' 显示到立即窗口。 Close #1 End Sub 'input #读取 'input 文件号,变量1，变量2,..变量N 'input #常用来读取write写的内容(分隔符为逗号,加双引号) Sub d3() Dim f, x f = ThisWorkbook.path & "\ruku.txt" Open f For Input As #1 Do While Not EOF(1) Input #1, x Debug.Print x Loop Close #1 End Sub Sub 读取write写入的文本() Dim f, y1, y2, y3, y4, y5 f = ThisWorkbook.path & "\ruku2.txt" Open f For Input As #1 Do While Not EOF(1) Input #1, y1, y2, y3, y4, y5 Debug.Print y1 & " " & y2 & " " & y3 & " " & y4 & " " & y5 Loop Close #1 End Sub Line Input #：取出完整的一 Sub 读取write写入的文本() Dim f, sr f = ThisWorkbook.path & "\Ruku3.txt" Open f For Input As #1 Do While Not EOF(1) Line Input #1, sr Debug.Print sr Loop Close #1 End Sub
    • 读取方法：adodb.stream
      • Function ReadFromTextFile(FileName, Optional CharSet = "gb2312") '读文件//返回所有txt所有文字内容，汉字无乱码，ADODB.Stream方法 Dim oStream As Object Dim sText As String Set oStream = CreateObject("ADODB.Stream") oStream.Open oStream.CharSet = CharSet 'unicode utf-8;Ascii; gb2312; big5; gbk oStream.Type = 2 'adTypeText oStream.LoadFromFile FileName ReadFromTextFile = oStream.ReadText() '完整提取出txt文件内容 oStream.Close Set oStream = Nothing End Function Sub WriteToTextFile(FilePath, ByVal Str, Optional CharSet = "gb2312", Optional bak = False) '需要备份文件再启用 '示例：Call WriteToTextFile("File/FileName.htm",Content,"UTF-8") Dim stm Set stm = CreateObject("adodb.stream") stm.Type = 2 '2-文本模式读取，1-二进制模式 stm.Mode = 3 '3-读写,1-读，2-写 stm.CharSet = CharSet 'unicode|utf-8;Ascii; gb2312; big5; gbk; stm.Open stm.WriteText Str ' stm.SaveToFile FilePath, 2 If Dir(FilePath) <> "" Then '文件存在备份后覆盖 If bak Then FileCopy FilePath, Left(FilePath, InStrRev(FilePath, "\")) & _ Left(Dir(FilePath), InStr(Dir(FilePath), ".") - 1) & _ "_" & Format(Now, "yyyymmddhhmm") & _ Mid(Dir(FilePath), InStrRev(Dir(FilePath), ".")) '备份文件 stm.SaveToFile FilePath, 2 '2可省略，adSaveCreateNotExist =1 ,　adSaveCreateOverWrite =2 Else stm.SaveToFile FilePath, 1 '不存在则创建文件 End If stm.flush stm.Close Set stm = Nothing End Sub
    • 监视文件打开时间记录
      • Option Explicit Private Sub Workbook_BeforeClose(Cancel As Boolean) Dim f As String f = ThisWorkbook.path & "\filetime.txt" Open f For Append As #1 Print #1, "Close: "; Now Close #1 End Sub Private Sub Workbook_Open() Dim f As String f = ThisWorkbook.path & "\filetime.txt" Open f For Append As #1 Print #1, "Open: "; Now Close #1 End Sub
  • 文件压缩
    • 压缩文件
      • Shell函数 Shell执行一个可执行文件.返回一个 Variant (Double)，如果成功的话，代表这个程序的任务 ID，若不成功，则会返回 0。 语法 Shell("可执行程序的路径 文件名或命令行",窗口的显示方式) Sub 用绘图程序打开图片() Dim mysh mysh = Shell("mspaint.exe " & ThisWorkbook.path & "\pic.jpg", vbMaximizedFocus) End Sub WinRar命令的命令行表示方法： WinRar程序路径 命令 开关1 开关2 开关3..开关N 压缩包路径 压缩的文件路径 命令是指要进行怎么样的操作，如A是压缩，X是解压缩 开关是具体操作时的细节，如压缩是是否把原文件删除，是否添加密码等 Sub RarFile() '压缩单个文件 Dim Rarexe As String Dim myRAR As String Dim Myfile As String Dim FileString As String Dim Result As Long Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径 myRAR = ThisWorkbook.path & "\A.rar" '压缩后的文件名 Myfile = ThisWorkbook.path & "\B*.xls" ' 指定要压缩的文件 FileString = Rarexe & " A " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串 Result = Shell(FileString, vbHide) '执行压缩 End Sub '如果文件名使用通配符,可以对同类的文件进行和压缩, '如果只有路径没有文件名,则会把这个文件夹进行压缩 Sub RarFile2() '多个文件压在一起 Dim Rarexe As String Dim myRAR As String Dim Myfile As String Dim FileString As String Dim Result As Long Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径 myRAR = ThisWorkbook.path & "\B.rar" '压缩后的文件名 ' Myfile = ThisWorkbook.path & "\B\*.xls" ' 指定要压缩的文件类型 Myfile = ThisWorkbook.path & "\B\" ' 指定要压缩的文件夹路径 FileString = Rarexe & " A " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串注意各字符间要加空格 Result = Shell(FileString, vbHide) '执行压缩 End Sub
    • 压缩文件路径
      • '-ep压缩时忽略路径,如果没有则会带上 '-ep1压缩时忽略基准路径 Sub RarFile2() '多个文件压在一起 Dim Rarexe As String Dim myRAR As String Dim Myfile As String Dim FileString As String Dim Result As Long Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径 myRAR = ThisWorkbook.path & "\B.rar" '压缩后的文件名 Myfile = ThisWorkbook.path & "\B" ' 指定要压缩的文件 FileString = Rarexe & " A -ep1 " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串 Result = Shell(FileString, vbHide) '执行压缩 End Sub
    • 添加压缩密码
      • Option Explicit '-p+密码 加密码后可以看到文件列表 '-hp+密码 加密码后无法看到文件列表 Sub RarFile9() '多个文件压在一起,并添加密码,可以看到文件列表 Dim Rarexe As String Dim myRAR As String Dim Myfile As String Dim FileString As String Dim Result As Long Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径 myRAR = ThisWorkbook.path & "\B.rar" '压缩后的文件名 Myfile = ThisWorkbook.path & "\B\" ' 指定要压缩的文件 FileString = Rarexe & " A -p123 " & myRAR & " " & Myfile Result = Shell(FileString, vbHide) '执行压缩 End Sub
    • 压缩后删除源文件
      • Option Explicit 'df压缩后删除原文件 'dr压缩后删除原文件到回收站 Sub RarFile2() '多个文件压在一起,删除原文件 Dim Rarexe As String Dim myRAR As String Dim Myfile As String Dim FileString As String Dim Result As Long Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径 myRAR = ThisWorkbook.path & "\B\B.rar" '压缩后的文件名 Myfile = ThisWorkbook.path & "\B\*.xls" ' 指定要压缩的文件 FileString = Rarexe & " A -df -p123 -ep " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串 Result = Shell(FileString, vbHide) '执行压缩 End Sub Sub RarFile3() '多个文件压在一起，删除原文件到回收站 Dim Rarexe As String Dim myRAR As String Dim Myfile As String Dim FileString As String Dim Result As Long Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径 myRAR = ThisWorkbook.path & "\B\B.rar" '压缩后的文件名 Myfile = ThisWorkbook.path & "\B\*.xls" ' 指定要压缩的文件 FileString = Rarexe & " A -dr -p123 -ep " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串 Result = Shell(FileString, vbHide) '执行压缩 End Sub
    • 压缩时排除文件
      • Sub RarFile2() '多个文件压在一起,排除某个文件 Dim Rarexe As String Dim myRAR As String Dim Myfile As String Dim FileString As String Dim Result As Long Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径 myRAR = ThisWorkbook.path & "\B.rar" '压缩后的文件名 Myfile = ThisWorkbook.path & "\B\*.xls" ' 指定要压缩的文件 FileString = Rarexe & " A -x" & ThisWorkbook.path & "\B\dr.xls -x" & ThisWorkbook.path & "\B\1.xls -ep " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串 Result = Shell(FileString, vbHide) '执行压缩 End Sub
    • 文件批量单独压缩
      • '借助dir和do循环，压缩指定文件夹中的所有文件 Sub RarFile4() '每个文件单独压缩 Dim Rarexe As String Dim myRAR As String Dim Myfile As String Dim FileString As String Dim Result As Long Dim p As String, f As String p = ThisWorkbook.path & "\B\" Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径 f = Dir(p & "*.xls") Do While f <> "" f = Split(f, ".")(0) Myfile = ThisWorkbook.path & "\B\" & f & ".xls" ' 指定要压缩的文件 myRAR = ThisWorkbook.path & "\B\" & f & ".rar" '压缩后的文件名 FileString = Rarexe & " A -ep " & myRAR & " " & Myfile 'rar程序的A命令压缩文件的字符串 Result = Shell(FileString, vbHide) '执行压缩 f = Dir Loop End Sub
    • 删除压缩包中的文件
      • Option Explicit 'D可以删除指定的文件 'WinRAR d 文件夹 可以带通配符的文件名或同类文件 Sub RarFile3() ' Dim Rarexe As String Dim myRAR As String Dim Myfile As String Dim FileString As String Dim Result As Long Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径 myRAR = ThisWorkbook.Path & "\B\B.rar" '在删除的压缩包名称 Myfile = ThisWorkbook.Path & "\B\说明.txt" ' 指定要删除的文件 FileString = Rarexe & " D " & myRAR & " " & "说明.txt" 'rar程序的A命令压缩文件的字符串 Result = Shell(FileString, vbHide) '执行程序 End Sub
    • 解压缩
      • Sub RarFile2() '解压缩 Dim Rarexe As String Dim myRAR As String Dim Mypath As String Dim FileString As String Dim Result As Long Rarexe = "C:\program files\winrar\winrar.exe" 'rar程序路径 myRAR = ThisWorkbook.Path & "\B\B.rar" '压缩后的文件名 Mypath = ThisWorkbook.Path & "\B\" ' 指定要压缩的文件 FileString = Rarexe & " x -ep -hp123 " & myRAR & " " & Mypath 'rar程序的A命令压缩文件的字符串 Result = Shell(FileString, vbHide) '执行压缩 End Sub 'x 表示解压缩 '-ep解压到当前文件夹下 '-hp123 解压含密码的压缩包
  • 文件夹及文件操作
    • 基本操作
      • 1 判断文件夹是否存在 dir函数的第二个参数是vbdirectory时可以返回路径下的指定文件和文件夹，如果结果为""，则表示不存在。 Sub w1() If Dir(ThisWorkbook.path & "\2011年报表2", vbDirectory) = "" Then MsgBox "不存在" Else MsgBox "存在" End If End Sub 2 新建文件夹 'Mikdir语句可以创建一个文件夹 Sub w2() MkDir ThisWorkbook.path & "\Test" End Sub 3 删除文件夹 'RmDir语句可以删除一个文件夹，如果想要使用 RmDir 来删除一个含有文件的目录或文件夹，则会发生错误。 '在试图删除目录或文件夹之前，先使用 Kill 语句来删除所有文件。 Sub w3() RmDir ThisWorkbook.path & "\test" End Sub 4 文件夹重命名 Sub w4() Name ThisWorkbook.path & "\test" As ThisWorkbook.path & "\test2" End Sub 5 文件夹移动 '同样使用name方法，可以达到移动的效果，而且连文件夹的文件一起移动 Sub w5() Name ThisWorkbook.path & "\test2" As ThisWorkbook.path & "\2011年报表\test100" End Sub 6 文件夹复制 Sub CopyFile_fso() Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") fso.CopyFolder ThisWorkbook.path & "\测试新建文件夹", ThisWorkbook.path & "\2011年报表\" Set fso = Nothing End Sub 7 打开文件夹 '使用shell函数桌面管理程序打开文件夹 Sub w7() Shell "explorer.exe " & ThisWorkbook.path & "\2011年报表", 1 End Sub ‘Shell "explorer.exespace(1)" exe后有空格
    • 遍历文件夹中的文件
      • '遍历指定文件夹中的文件 Sub 遍历文件() Dim Filename As String, mypath As String, k As Integer mypath = ThisWorkbook.path & "\2011年报表\1月\A公司\" Range("A1:A10") = "" Filename = Dir(mypath & "*月*.xls") Do k = k + 1 Cells(k, 1) = Filename Filename = Dir Loop Until Filename = "" End Sub Sub 遍历子文件() Dim Filename As String, mypath As String, k As Integer mypath = ThisWorkbook.path & "\2011年报表\" Range("A1:A10") = "" Filename = Dir(mypath, vbDirectory) Do If Not Filename Like "*.*" Then ’遍历文件夹时"."".. "代表上一级文件夹和当前文件夹，需排除 k = k + 1 Cells(k, 1) = Filename End If Filename = Dir Loop Until Filename = "" End Sub
    • 遍历所有文件夹父子转换法
      • 直接使用: arr=提取文件信息(文件夹路径，类型文件） Function 提取文件信息(ByVal MyPath, Optional ByVal fileStr = "*.*") ''返回一个数组6列 '1 列 -纯文件名+后缀 '2 列 -完整路径 '3 列 纯文件名 '4列 纯后缀文件类型 '5列 文件修改时间 '6列 大小 Dim arr(1 To 10000) As String Dim f, i, k, f2, f3, x Dim arr1(1 To 100000, 1 To 6) As String, q As Integer Dim fso As Object, myfile As Object arr(1) = MyPath & "\" i = 1: k = 1 Do While i < UBound(arr) If arr(i) = "" Then Exit Do f = Dir(arr(i), vbDirectory) Do If InStr(f, ".") = 0 And f <> "" Then k = k + 1 arr(k) = arr(i) & f & "\" End If f = Dir Loop Until f = "" i = i + 1 Loop '*******下面是提取各个文件夹的文件*** Set fso = CreateObject("Scripting.FileSystemObject") For x = 1 To UBound(arr) If arr(x) = "" Then Exit For f3 = Dir(arr(x) & fileStr) Do While f3 <> "" q = q + 1 arr1(q, 2) = arr(x) & f3 Set myfile = fso.GetFile(arr1(q, 2)) arr1(q, 1) = f3 arr1(q, 3) = fso.GetBaseName(arr1(q, 2)) arr1(q, 4) = Mid(arr1(q, 1), Len(arr1(q, 3)) + 2) arr1(q, 5) = myfile.DateLastModified arr1(q, 6) = Format((myfile.Size) / 1024, "0.00") f3 = Dir Loop Next x 提取文件信息 = arr1 End Function
• 27. 窗体与控件
  • 窗体的使用
    • 一、窗体的使用 1 窗体的插入和启用 '插入菜单--用户窗体 '工程窗口中右键--插入--用户窗体 2 窗体的运行 手工点运行按钮(快捷键F5) 用代码执行 Sub 显示窗体() 入库单.Show End Sub 3 窗体的关闭 手工点关闭按钮 用代码执行关闭 Unload Me 4 窗体的显示设置 A 窗体的标题 设置Caption的值 B 窗体的背景色 设置BackColor的颜色值 C 窗体的背景图片 UserForm1.Picture=loadpicture(图片路径) UserForm1.PictureAlignment UserForm1.PictureSizeMode UserForm1.PictureTiling 5 窗体的位置和大小 height 窗体高 left top 窗体与excel窗口左边或顶边之间的距离 Width 窗体的宽度 StartupPosition '设置窗体启动时的位置 6 窗体显示的一些行为 ShowModal 设置在窗体显示时,是否可以编辑单元格区域 7 窗体的删除 选中窗体，右键，移除。。。
  • 控件的使用
    • 二 控件的使用 1 控件的插入 '控件的插入是通过控件工具箱来实现的 '控件工具箱中显示的是常用控件,如果想加载其他控件, 2 控件的删除 '选取后工直接删除即可 3 控件的格式对齐与分布 '可以通过格式菜单来完成 4 控件的tab顺序 '按tab键后的控件选取顺序 5 控件的循环 '在窗体内表示所有控件的集合是controls 'Controls(序号) 'Controls("控件名称") 6 判断控件的类型 用typename函数来判断一个控件的类型 Private Sub CommandButton1_Click() Dim x As Integer For x = 0 To Me.Controls.Count - 1 If TypeName(Controls(x)) = "TextBox" Then End If Next x End Sub
  • 窗体事件
    • 概述：窗体事件,是作用于窗体上的动作引发的程序的自动运行 '窗体中的事件 1 窗体加载事件：当窗体出现之前运行的程序 Private Sub UserForm_Initialize() MsgBox Me.Caption End Sub 2 窗体关闭前的事件 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = 0 Then Cancel = 1 End Sub Cancel 值为>0的值时禁止关闭动作的发生 CloseMode 关闭的模式 0点击关闭按钮 1 是使用unload 关闭 if closemode=0 then cancel=true 3 窗体关闭后的事件 Private Sub UserForm_Terminate() MsgBox 2 End Sub 4 窗体活动和非活动事件 Private Sub UserForm_Deactivate() End Sub 5 窗体的单击和双击事件 Private Sub UserForm_Click() Unload Me End Sub 6 键盘事件 Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) '按下键时 If keycode=13 then MsgBox "你按下了ctrl+a组合键" End If End Sub 'keycode是指按下键的键标号,一键一标号 'shift 是按下shift(值为1) or ctrl(值为2)或alt(值为3) Private Sub UserForm_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) '按下键后起来时 MsgBox "KeyCode:" & KeyCode End Sub Private Sub UserForm_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger) '按下键时 MsgBox "KeyAscii:" & KeyAscii End Sub 'KeyAscii是键盘输入后传递给程序的ASCII码,受大小字写的影响,一个键也会有两个码,它无法监控方向键 7 鼠标事件 Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) '鼠标左键按下 If Button = 1 And Shift = 3 Then MsgBox "你在坐标为x:" & X & " Y:" & Y & " 的位置点击了鼠标左键,并且按下了ctrl+shift组合键" End If End Sub ' button 值按左键返回1,按右键返回2,按中键返回4 ' shift 按Shift返回1,按ctrl返回2,shift+ctrl返回3,Atl按回4 ' X,Y 是指点击的位置 Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) '鼠标左键按下起来时 End Sub Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) '鼠标移动时 If Shift = 1 Then Me.CommandButton1.BackColor = &H8000000F End If End Sub Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Shift = 1 Then CommandButton1.BackColor = &H8080FF End If End Sub
  • 常用控件
    • 按钮控件
      • 按钮控件 一 按钮显示 1 鼠标放在按钮上时可以显示的提示文字 设置controltiptext属性 2 在按钮上添加图片 设置PicturePosition属性 3 隐藏按钮 设置Visible的值=true 二 按钮功能 1 设置热键,按alt+设置的键可以运行该按钮的click事件 Accelerator的属性 2 按钮是否可用,可以让按钮变成灰色 Enabled 3 设置按ENTER和Esc按钮时运行指定按钮的命令 Cancel的值为TRUE，表示该按钮会响应ESC按钮 Default的值为TRUE，表示该按钮会响应Enter键按下 注意:只有没有命令按钮响应获取焦点时才有效 Private Sub CommandButton2_Click() MsgBox "测试esc按钮" End Sub Private Sub CommandButton4_Click() MsgBox "测试enter" End Sub Private Sub CommandButton1_Click() MsgBox "测试按钮快捷键" End Sub 4 Tag的用途 'tag可以作为控件的特别标识，用于判断和记忆信息 Sub 显示tag值大于20的按钮() Dim x For x = 0 To Controls.Count - 1 If Val(Controls(x).Tag) > 20 Then MsgBox Controls(x).Name End If Next x End Sub Private Sub CommandButton6_Click() Call 显示tag值大于20的按钮 End Sub 5 一个按钮执行多个程序 Private Sub CommandButton5_Click() If CommandButton5.Caption = "打开" Then MsgBox "你已打开" CommandButton5.Caption = "关闭" Else MsgBox "你已关闭" CommandButton5.Caption = "打开" End If End Sub
    • 标签控件
      • Option Explicit 按钮控件 一 功能 显示文本 显示 1 自动适应字体大小。 AutoSize的属性设置为true可以自动调整大小以完全显示文字 2 背景透明 BackStyle值0为透明 1 不透明 3 文字对齐 TextAlign属性1左对齐2居中对齐3右对齐 4 字体的自动换行 WordWrap属性如果为True则自动换行(默认)
    • 文字框控件
      • 文字框控件 一 显示 1 多行显示 MultiLine 属性值为true时，可以多行显示文本 2 文本框对齐 左右对齐可以用TextAlign对齐，但上下对齐则没有相应的属性设置 3 密码样式 可以设置passwordChar属性来隐藏输入的内容 4 行列超过宽度或高度时添加滚动条 ScrollBars 属性可以设置垂直和水平滚动条 5 强制换行符号 EnterKeyBehavior的属性值为TRUE时,可以强制换行.按回车即可以转到下一行. '如果用代码,可以借用回车符来实现转行 Private Sub CommandButton1_Click() TextBox2 = "excelpx" & Chr(10) & ".com" 'Cha(10)换行符 End Sub 二 功能 1 自动跳到一下个tab顺序的控件 AutoTab属性设置为true，当文字框输入字符数）大于（maxlenth）时跳转下一个tab 2 锁定文本和禁用 locked属性为true时，显示正常，可以选取，可以复制，但不能编辑。 enable属性为false时，显示灰色，不能选取 3 是否允许拖放复制值 DragBehavior 属性值为1时,可以进行拖放 三 常用方法和属性 1 lineCount属性:获得文本框的行数 2 SelLength属性可以获得当前文本框中选取的文本长度 3 SelText,可以获得当前文本框中选取的文本 4 SetFocus 获得焦点 Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean) ' TextBox2 = TextBox3.SelLength & ":" & TextBox3.SelText & ":" & TextBox3.SelStart End Sub 四 事件 1 当文本框值发生改变量时的事件 Private Sub 用户名_Change() MsgBox 123 End Sub 2 当离开文本框时，如果数据发生了改变，则发生此事件 Private Sub TextBox1_AfterUpdate() ' MsgBox 123 End Sub 3 焦点进入文本框时的事件 Private Sub 用户名_Enter() ' MsgBox "我是用户名。" End Sub 4 离开文本框时的事件 Private Sub 用户名_Exit(ByVal Cancel As MSForms.ReturnBoolean) '必须输入用户名 If 用户名.Text = "" Then Cancel = True MsgBox "你没有输入用户名，不能跳过" & Chr(10) & "请输入内容" End If End Sub 'Cancel参数常用于取消该事件的发生,本事件是指取消离开动作，禁止离开 Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) '密码必须输入数字 If Not VBA.IsNumeric(TextBox1.Value) And TextBox1.Value <> "" Then Cancel = True MsgBox "密码只能输入数字，请重新输入" End If End Sub
    • 列表框listbox
      • 列表框 属性和方法 1 ListStyle值为0时,样式为默认样式，无单选或多选框，如果为1时则有 2 Selected(行数) 可以判断列表框中某行是否被选取 3 ListCount 列表框的条目个数 4 MultiSelect 属性值为0只能选一个，1可以用鼠标点击多选或取消,2需要按shift或ctrl才能多选 5 boundColumn 绑定的第几列的值value 6 boundCount 显示多少列 7 ListBox1.ListIndex 返回当前选中序号 Private Sub CommandButton1_Click() '显示选取的行 Dim x As Integer For x = 0 To LB1.ListCount - 1 If LB1.Selected(x) = True Then 'Selected是选取的集合 MsgBox x & LB1.List(x, 0) 'list(行,列)来表示在列表框中的位置 ,行与列都是从0开始 End If Next x End Sub Private Sub CommandButton2_Click() '删除选取的行 Dim k As Integer k = -1 Do While k < LB1.ListCount - 1 k = k + 1 If LB1.Selected(k) = True Then 'Selected是选取的集合 LB1.RemoveItem k End If Loop End Sub Private Sub OptionButton1_Click() LB1.ListStyle = 0 'Style是风格、类型的意思 。0是普通 End Sub Private Sub OptionButton2_Click() LB1.ListStyle = 1 '表示是带有复选框 End Sub Private Sub UserForm_Initialize() Dim x As Integer For x = 1 To Sheets.Count LB1.AddItem Sheets(x).Name Next x End Sub listbox.xlsm https://www.aliyundrive.com/s/QBrHDQfgRJj 提取码: id51
    • 组合框
      • 组合框 一 显示 1 显示多列内容 'ColumnCount属性可以设置显示的列数 'TextColumn选取多列时显示N列的内容 'BoundColumn属性可以指定返回第N列的值 Private Sub CommandButton1_Click() 商品.RowSource = "sheet3!a2:c9" 'rowsource属性可以从工作表中导入数据 商品.ColumnCount = 3 商品.ColumnHeads = True End Sub 注:Columnheads只在引用工作表数据源时才有效，而且数据源不能包括标题行 Private Sub CommandButton2_Click() '设置返回组合框第二列的值 Dim arr arr = Range("b2:d9").Value '商品.ColumnHeads = True 商品.List = arr 商品.ColumnCount = 3 商品.TextColumn = 3 '组合框中显示第3列的值 商品.BoundColumn = 2 '选取后第2列为默认值 End Sub Private Sub 商品_Change() Dim sr If 商品.ListIndex <> -1 Then '组合框没选取时listindex会返回-1 TextBox1 = 商品.Value TextBox2 = 商品.List(商品.ListIndex, 2) End If End Sub 2、获得焦点自动打开下拉列表 Private Sub 商品_Enter() 商品.DropDown End Sub 3 列表显示最大条目个数 Listrows属性后设置 4 组合框下拉按钮的图标 DropButtonStyle 属性设置不同的类型 ShowDropButtonWhen 属性可以设置是否显示下拉按钮图标 5 设置列宽 Private Sub CommandButton4_Click() 商品.ColumnWidths = "70 磅;60 磅;67 磅" '以磅为单位 商品.ColumnWidths = "2 厘米;2 厘米;5 厘米" '以厘米为单位 ' 商品.ColumnWidths = "2 英寸;2 英寸;3 英寸" '以英寸为单位 End Sub 二 功能 1 向组合框内添加内容 Private Sub UserForm_Initialize() A 使用additem方法添加 商品.AddItem "A" 商品.AddItem "B" 商品.AddItem "C" B 使用常量数组添加 ' 商品.List = Array("A", "B", "C") C 使用VBA数组添加 Dim arr(1 To 3), x For x = 1 To 3 arr(x) = Cells(x + 1, "g") Next x 商品.List = arr D 创建和单元格链接 商品.RowSource = "sheet3!G2:G4" End Sub 2 删除指定行 Private Sub CommandButton3_Click() 商品.RemoveItem 1 '删除指定行 商品.RemoveItem 商品.ListIndex '删除选中的行ListIndex属返回选定的行数，不能删除rowsourse设置的填充数据 End Sub 3 提取选取的多列内容 list(行数,列数) 行和列都是从0开始算起的 4 是否可以输入列表内容以外的内容 MatchRequired 属性值为true时，必须输入组合框中含有的
• 28. 代码操作代码
  • VBE对象
    • VBE对象是根对象，表示在VBA编辑器中存在的所有对象的最上层对象 一 VBAproject对象: VBE编辑器中的工程 1 VBComponents对象：表示工程中所有的部件集合，包括Excel对象、窗体、模块、类模块。 1) CodeModule 对象：表示部件中相关的代码 操作VBE需要做的工作 1 设置信任 'excel2003中，工具--宏--安全性--可靠发行商，选中“信任对于..." 'excel2007和excel2010，开发工具--安全性--宏设置--选中"对...的信任" 2 引用 在VBA编辑器找到工具-引用-勾选MicroSoft Visual Basic for Applications Extensibility Library，如果电脑安装了VB6，可以引用Microsoft Visual Basic 6.0 Extensibility。
  • 返回模块信息
    •  1、返回模块的行数 Sub 返回模块A中的总行数() MsgBox ThisWorkbook.VBProject.VBComponents("A").CodeModule.CountOfLines End Sub Sub 返回过程test中的总行数() MsgBox ThisWorkbook.VBProject.VBComponents("A").CodeModule.ProcCountLines("test", vbext_pk_Proc) End Sub Sub 返回过程fe中开始行数() MsgBox ThisWorkbook.VBProject.VBComponents("A").CodeModule.ProcBodyLine("fe", vbext_pk_Proc) End Sub 'vbext_pk_Get 指定一个返回属性值的过程 'vbext_pk_Let 指定一个赋值给属性的过程 'vbext_pk_Set 指定一个给对象设置引用的过程 'vbext_pk_Proc 指定所有过程除了Property 过程 2 返回模块的内容 Sub 返回过程fe中的所有代码() Dim 开始行数, 总行数 With ThisWorkbook.VBProject.VBComponents("A").CodeModule 开始行数 = .ProcBodyLine("fe", vbext_pk_Proc) 总行数 = .ProcCountLines("fe", vbext_pk_Proc) MsgBox .Lines(开始行数, 总行数) End With End Sub Sub 返回第7行所在的过程名() MsgBox ThisWorkbook.VBProject.VBComponents("A").CodeModule.ProcOfLine(7, vbext_pk_Proc) End Sub 判断模块和过程是否存在 Sub 判断A模块是否存在() On Error Resume Next If ThisWorkbook.VBProject.VBComponents("c") Is Nothing Then MsgBox "B模块没有存在" Else MsgBox "B模块存在" End If End Sub Sub 判断是否存在b过程() On Error Resume Next Dim 开始行数 开始行数 = ThisWorkbook.VBProject.VBComponents("A").CodeModule.ProcBodyLine("B", vbext_pk_Proc) If Err.Number = 35 Then MsgBox "不存在B过程" Else MsgBox "存在B过程" End If End Sub 返回工程中所有部件名称 Sub 显示部件列表() Dim x As Byte With ThisWorkbook.VBProject For x = 1 To .VBComponents.Count Cells(x + 1, 1) = .VBComponents(x).Name Cells(x + 1, 2) = .VBComponents(x).Type Next x End With End Sub
  • 模块中操作
    • 一 添加模块、过程、代码 1 添加模块 Sub 添加新模块B() With ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule) .Name = "B" End With End Sub ' vbext_ct_ClassModule 将一个类模块添加到集合 ' vbext_ct_MSForm 将窗体添加到集合 ' vbext_ct_StdModule 将标准模块添加到集合 2 在模块中添加代码 Sub 添加新过程() Dim sr, code sr = "Sub ABC()" & vbCrLf & "Msgbox ""测试添加代码""" & vbCrLf & "End Sub" 'MsgBox sr With ThisWorkbook.VBProject.VBComponents("B").CodeModule .AddFromString sr End With End Sub 3 在模块中插入代码 Sub 在B模块中的第3行插入一行代码() With ThisWorkbook.VBProject.VBComponents("B").CodeModule .InsertLines 3, "sheets(1).Select" End With End Sub 二 删除模块、过程、代码 1 删除模块 Sub 删除B模块() With ThisWorkbook.VBProject.VBComponents .Remove ThisWorkbook.VBProject.VBComponents("B") End With End Sub 2 删除过程 Sub 删除B模块中的ABC过程() Dim 开始行数, 总行数 With ThisWorkbook.VBProject.VBComponents("B").CodeModule 开始行数 = .ProcBodyLine("ABC", vbext_pk_Proc) 总行数 = .ProcCountLines("ABC", vbext_pk_Proc) .DeleteLines 开始行数, 总行数 End With End Sub 三 导入、导出和替换一个模块或代码 Sub 导出一个模块() ThisWorkbook.VBProject.VBComponents("A").Export "D:/A.bas" End Sub Sub 导入一个模块() ThisWorkbook.VBProject.VBComponents.Import "D:/A.bas" End Sub Sub 替换一个模块() '先删除模块,然后导入新模块 ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents("A") ThisWorkbook.VBProject.VBComponents.Import "D:/A.bas" End Sub Sub 替换A模块的B程序第一行代码() Dim 开始行数 With ThisWorkbook.VBProject.VBComponents("B").CodeModule 开始行数 = .ProcBodyLine("ABC", vbext_pk_Proc) .ReplaceLine 开始行数 + 1, "MsgBox ""修改后""" End With End Sub 四 模块的查找 'Find(查找内容,开始行数,开始列始,结束行数,结束列数,是否匹配) Sub 在B模块中查找() With ThisWorkbook.VBProject.VBComponents("B").CodeModule MsgBox .Find("我", 1, 1, 1, 1) End With End Sub
• 29. 类模块
  • 入门
    • 一、什么是类模块 "类"，相同的事物划成的一个类别。象人类，鸟类等。在VBA中可以创建类的模块就是类模块。 二、类模块有什么作用？ 类就象一个设计好的模板，它生产的产品大小、形状，它所具体的功能已设置完成，当需要这类产品时，我们只需要把材料放进模板，就可以马上生产出一个和模板有相同特征、功能的产品。 '对于同类的产品可以通过循环批量操作，不必一个个的设置。具体的作用有以下几方面: '1 让代码可读性更强 '2 调用excel对象的一些事件,如程序级事件,内嵌图表事件,菜单命令事件等. '3 封装API,让代码更简捷易懂 '4 创建控件数组. '5 团队协作时,编写完整模块后可以方便队友调用,减少开发时间 三、怎么创建类模块 插入菜单(或在工程窗口右键--插入)--类模块。 四、类模块相关语句 1 property let '作用:生成对象的可写入属性 Property Let 属性名称(参数) Xiadi = xdi End Property 2 property Get() '作用，生成对象的可读取属性 Property Get 属性名称() End Property 3 Property Set '作用:生成子对象 Property Set 子对象名称(对象) End Property 4 Sub语句 作用:生成方法 5 Function语句
  • 使用类模块
    • '使用类，首先要创建一个新的实例。即 'dim 变量 as new 类模块名称 '创建后，就可以使用该类的对象、方法和属性了  ***调用MyRng类**** Sub 设置单元格() Dim rggg As New MyRng Set rggg.红色单元格 = Range("B5") Set rggg.绿色单元格 = Range("B6") End Sub  ***日报表类***** Sub 设置模板工作表类模块方法() Dim shh As New 日报表 '创建一个日报表类的实例 Set shh.模板 = Sheets("sheet2") End Sub Sub 设置模板工作表调用宏方法() 设置模板 Sheets("sheet2") End Sub Sub 设置模板(sh As Worksheet) sh.Range("a1:g1").Merge sh.Range("a1") = "营业日报表" sh.Range("a1").HorizontalAlignment = xlCenter sh.Range("d3") = Date End Sub  ***调用梯形面积类**** Sub 面积之类模块() Dim 梯形 As New 梯形面积 With 梯形 .上底 = 2 .下底 = 3 .高 = 4 MsgBox .面积 MsgBox .高 End With End Sub Sub 面积之自定义函数() MsgBox mianji(2, 3, 4) End Sub Function mianji(上底, 下底, 高)‘函数 mianji = (上底 + 下底) * 高 / 2 End Function  *****调用万能计算器类** Sub 计算() Dim 计算 As New 万能计算器 With 计算 Set .单元格区域 = Sheets("sheet3").Range("a1:a10") .求和 .平均数 .求个数 End With End Sub
  • 类模块事件
  • 类模块的封装
    • 类模块：功能库  Sub 表达式变公式() Dim g As New 功能库 g.公式变数值 Range("b3") g.自定义格式变数值 Range("c3") g.表达式变公式 Range("d3") End Sub Sub 删除重复值() Dim cc As New 功能库 cc.删除重复数据 Selection End Sub 类模块：函数库  Sub 计算() Dim f As New 函数库 Debug.Print "和：" & f.求和(Range("a1:a5")) Debug.Print "平均值：" & f.平均数(Range("a1:a5")) Debug.Print "最大值：" & f.最大值(Range("a1:a5")) End Sub
• 30. 数据库
  • 数据库基本操作
    • 基本概念
      • 1 怎么样才能操作数据库？ 使用ADO建立和数据库的连接，然后用ADO对象和sql语言对数据库进行操作。 2 SQL是什么? 'SQL（Structured Query Language)是一种查询语言，可以查询、更新数据库中的数据。 3 SQL可以查询哪些数据库? SQL是一种通用的查询语言,可以查询EXCEL,ACCESS,SQL SERVER等各种数据库 4 ADO是什么？ ADO是新的数据库存取技术，可以建立与各数据库库的连接，也可以对数据库数据进行添加、更新、删除等操作 5 我们学习SQL+ADO访问数据库有什么用处? '1 可以在不打开EXCEL文件的情况下,从文件中提取数据. '2 可以从建立连接的专业软件数据库中提取数据.如财务软件等. 6 怎么使用ADO? 引用法 '工具--引用---Microsoft Activex..D...O" '引用后再声明: Dim conn As New Connection 声明链接对象 ' Dim rst As New Recordset 声明记录集对象 创建法 '使用CreateObject函数创建 'Set conn = CreateObject("adodb.connection") '创建ado对象 'Set rst = CreateObject("ADODB.recordset") '创建记录集
    • ADO基本对象
      • 一、Connection对象 1 建立和数据库的连接 .Open Dim conn As New Connection conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.Path & "/Database/exceldata.xls" 'Conn.Open:打开数据库的连接 'provider=microsoft.jet.oledb.4.0 数据库引擎版本 'extended properties=excel 8.0 连接的是Excel8.0版本(excel2000以后的版本),Excel不是标准的数据库格式,所以要设置扩展属性 'data source=" & ThisWorkbook.Path & "/数据库.xls" 数据库路径 **以下是连接其他数据库或文件的字符串表达式*** 1 Mysql数据库 strDriver = "Provider=SQLOLEDB;DataSource=" & Path & ";Initial Catolog=" & strDataName 2 TXT文件 'strDriver = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='text;IMEX=1;HDR=NO;FMT=Delimited;';Data Source=" & Path 3 MSSQL数据库 'strDriver = "Provider=MSDASQL;Driver={SQL Server};Server=" & Path & ";Database=" & strDataName 4 Oracle数据库 'strDriver= "Provider=madaora;Data Source=MyOracleDB; User Id=UserID; Password=Password" 2 执行sql语句 .Execute SQL 增加新表格：.Execute "Create 表格名 字段和属性" 增加新记录：.Execute "Insert into 表名 (字段1, 字段2,... 字段n) VALUES(值1,值2,... 值n)" 删除记录： .Execute "Delete from 表名 where 条件 修改旧记录：.Execute "Update 表名称 SET 列1 = 新值,列2=新值 WHERE 列名称 = 某值 筛选记录: .Execute "Select 字段 from 表 where 条件 二、Recordset对象 '作用 打开记录集操作记录 1 打开游标(记录集) rst.Open sql或command语句等,已打开的conn链接, 2 添加新记录 AddNew 单个字段或数组,单个值或数组 '或 ' rst.AddNew '添加新的记录 ' rst.Fields("姓名") = "伍天明" 'Fields("字段名")表示某列的记录 ' rst.Fields("年龄") = 28 ' rst.Fields("性别") = "男" ' rst.Update '添加记录后要更新 3 修改记录 'rst.Update 字段数组, 值或数组 4 删除记录 'rst.delete 5 在记录中循环 'BOF 在记录的最前面 'EOF 在记录的结尾 'GetRows(默认值-1,Start, 字段)'Start 0从当前记录开始,1从第一条记录,2从最后一条记录开始
    • 记录添加
      • 1 使用.Execute 执行 Insert 语句 Sub 添加1() Dim conn As New Connection Dim sql As String Dim data As New 数据库 conn.Open data.Excel数据库 sql = "Insert into [Sheet1$] (姓名, 年龄, 性别) VALUES('张雨生', 35, '男')" conn.Execute sql conn.Close Set conn = Nothing End Sub 2 使用AddNew方法添加记录 Sub 添加() Dim conn As New Connection Dim rst As New Recordset 'Set conn = CreateObject("adodb.connection") '创建ado对象 'Set rst = CreateObject("ADODB.recordset") '创建记录集 Dim data As New 数据库 conn.Open data.Excel数据库 rst.Open "select * from [Sheet1$]", conn, adOpenForwardOnly, adLockOptimistic rst.AddNew Array("姓名", "年龄", "性别"), Array("李楠", 25, "男") 'rst.AddNew '添加新的记录 ' rst.Fields("姓名") = "伍天明w" 'Fields("字段名")表示某列的记录 ' rst.Fields("年龄") = 28 ' rst.Fields("性别") = "男" 'rst.Update '添加记录后要更新 rst.Close '关闭记录集 conn.Close '关闭与数据库的链接 Set rst = Nothing '释放对象 Set conn = Nothing '释放对象 MsgBox "已输入到数据库" End Sub Sub 添加到access() Dim cnn As New ADODB.Connection Dim rst As New ADODB.Recordset Dim sq1 As String Dim data As New 数据库 cnn.Open data.Access数据库 '链接方法同excel数据链接 sq1 = "Select * from 员工" '从员工表中查询 rst.Open sq1, cnn, adOpenKeyset, adLockOptimistic rst.AddNew rst.Fields("姓名") = "李楠" rst.Fields("年龄") = 23 rst.Fields("性别") = "女" rst.Update cnn.Close Set cnn = Nothing MsgBox "添加成功" End Sub
    • 记录查找
      • '数据库中查找记录,可以执行含where条件判断的Select语句.符合条件的可能只有一条记录.也可能是多条记录 '单个记录查找 Sub 筛选() Dim conn As New Connection Dim data As New 数据库 conn.Open data.Excel数据库 Range("a1:c100") = "" Range("a2").CopyFromRecordset conn.Execute("select * from [sheet1$] where val(年龄) > 25") conn.Close Set conn = Nothing End Sub Sub 查找() Set conn = CreateObject("adodb.connection") Set rst = CreateObject("ADODB.recordset") Dim data As New 数据库 conn.Open data.Excel数据库 rst.Open "select * from [Sheet1$] where 姓名='李楠2'", conn, adOpenKeyset, adLockOptimistic If rst.RecordCount < 1 Then MsgBox "找不到该姓名" GoTo 100 End If Debug.Print "年龄:" & rst.Fields("年龄") Debug.Print "性别:" & rst.Fields("性别") ' MsgBox "查找成功" 100: rst.Close conn.Close Set rst = Nothing Set conn = Nothing End Sub Sub FindX(xingming As String) Set conn = CreateObject("adodb.connection") Set rst = CreateObject("ADODB.recordset") Dim data As New 数据库 conn.Open data.Access数据库 rst.Open "select * from 员工 where 姓名='" & xingming & "'", conn, adOpenKeyset, adLockOptimistic If rst.RecordCount < 1 Then MsgBox "找不到该姓名" GoTo 100 End If Debug.Print "年龄:" & rst.Fields("年龄") Debug.Print "性别:" & rst.Fields("性别") ' MsgBox "查找成功" 100: rst.Close conn.Close Set rst = Nothing Set conn = Nothing End Sub
    • 记录删除
      • Option Explicit 'SQL语句中delete语句可以删除符合条件的记录 Delete * from 数库表 where 条件 ' 注:Delete语句不支持Excel数据库删除操作,所以要想删除Excel中的数据,只能用其他方法,如打开后删除. Sub ADO删除方法() Dim cnn As New ADODB.Connection Dim rst As New ADODB.Recordset Dim sq1 As String Dim data As New 数据库 cnn.Open data.Access数据库 sq1 = "delete from 员工 where 姓名='" & "李楠" & " '" cnn.Execute sq1 MsgBox "删除成功" cnn.Close Set cnn = Nothing Call 查 End Sub Sub ADO删除方法2() Dim cnn As New ADODB.Connection Dim rst As New ADODB.Recordset Dim sq1 As String Dim data As New 数据库 cnn.Open data.Access数据库 sq1 = "select * from 员工 where 姓名='" & "李楠" & " '" rst.Open sq1, cnn, adOpenForwardOnly, adLockOptimistic rst.Delete MsgBox "删除成功" cnn.Close Set cnn = Nothing Call 查 End Sub
    • 记录修改
      • 修改记录可以用两种方式实现 '1 用update语句 'Update '2 用Recordset对象的update方法 'Recordset对象.Update 字段,值 '注:字段和值都可以用数组来同时更新多个字段的信息 Sub 记录修改() 'Set conn = CreateObject("adodb.connection") Dim conn As New Connection Dim rst As New Recordset Dim sql As String Dim nl As String, xb As String, xm As String xm = "唐七七" xb = "男" nl = 28 conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.path & "/Database/exceldata.xls" sql = "update [Sheet1$] set 年龄=" & nl & ",性别='" & xb & "' where 姓名='" & xm & "'" conn.Execute sql conn.Close Set conn = Nothing MsgBox "数据库的记录已修改" End Sub Sub 记录修改2() Dim conn As New Connection Dim rst As New Recordset Dim sql As String Dim nl As String, xb As String, xm As String xm = "唐七七" xb = "女" nl = 19 conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.path & "/Database/exceldata.xls" sql = "Select * from [sheet1$] where 姓名='" & xm & "'" rst.Open sql, conn, adOpenKeyset, adLockOptimistic rst.Update Array("性别", "年龄"), Array(xb, nl) rst.Clone conn.Close Set rst = Nothing Set conn = Nothing MsgBox "数据库的记录已修改" End Sub
    • 记录间循环
      • Sub 在记录之间循环() Dim conn As New Connection Dim rst As New Recordset Dim data As New 数据库 Dim x conn.Open data.Excel数据库 rst.Open "select * from [Sheet1$] where val(年龄)>25", conn, adOpenKeyset, adLockOptimistic For x = 1 To rst.RecordCount If rst.EOF Then MsgBox "已到最后一条记录" Else Debug.Print rst.Fields("姓名") & rst.Fields("年龄") rst.MoveNext End If Next x rst.Close conn.Close Set rst = Nothing Set conn = Nothing End Sub Sub 在记录之间循环2() Dim conn As New Connection Dim rst As New Recordset Dim data As New 数据库 Dim x, arr, arr1 conn.Open data.Excel数据库 rst.Open "select * from [Sheet1$] where val(年龄)>25", conn, adOpenKeyset, adLockOptimistic 'MsgBox rst.RecordCount arr1 = Array("姓名", "年龄") arr = Application.Transpose(rst.GetRows(-1, 1, arr1)) For x = 1 To UBound(arr, 1) Debug.Print arr(x, 1) & "," & arr(x, 2) Next x rst.Close conn.Close Set rst = Nothing Set conn = Nothing End Sub
  • SQL语言基础：Select语句
    • 按条件筛选
      •  按条件筛选---数字条件 直接用对比符号,><= Sub 按条件筛选1() Dim sql As String Dim data As New 数据库 sql = "Select * from [sheet1$] Where 销售单价 > 100" data.执行筛选 data.Excel数据库, sql End Sub 按条件筛选---字符条件 Sub 按条件筛选2() Dim sql As String Dim data As New 数据库 sql = "Select * from [sheet1$] Where 物品名称 ='挡泥板'" data.执行筛选 data.Excel数据库, sql End Sub 按条件筛选---日期条件 Sub 按条件筛选3() Dim sql As String Dim data As New 数据库 sql = "Select * from [sheet1$] Where 出库日期 =#2005-1-4#" data.执行筛选 data.Excel数据库, sql End Sub 按条件筛选---区间条件 Sub 按条件筛选4() Dim sql As String Dim data As New 数据库 sql = "Select * from [sheet1$] Where 出库日期 between #2005-1-4# and #2005-1-10#" data.执行筛选 data.Excel数据库, sql End Sub 按条件筛选--多个条件 '用and,OR连接 Sub 按条件筛选5() Dim sql As String Dim data As New 数据库 sql = "Select * from [sheet1$] Where 出库日期 between #2005-1-4# and #2005-1-10# and 销售单价>100" data.执行筛选 data.Excel数据库, sql End Sub 按条件筛选--模糊条件 '%表示任意多个字符,_(下划线)表示单个占位符 Sub 按条件筛选6() Dim sql As String Dim data As New 数据库 sql = "Select * from [sheet1$] Where 物品名称 like '%扶手%'" data.执行筛选 data.Excel数据库, sql End Sub 按条件筛选--插入变量 Sub 按条件筛选7() Dim sql As String Dim data As New 数据库 Dim sr sr = "挡泥板" sql = "Select * from [sheet1$] Where 物品名称 ='" & sr & "'" data.执行筛选 data.Excel数据库, sql End Sub 按条件筛选--在字符串组里 Sub 按条件筛选8() Dim sql As String Dim data As New 数据库 sql = "Select * from [sheet1$] Where 物品名称 in('车衣','扶手箱')" data.执行筛选 data.Excel数据库, sql End Sub 按条件筛选--借用函数 Sub 按条件筛选9() Dim sql As String Dim data As New 数据库 sql = "Select * from [sheet1$] Where left(物品代码,3)='028'" data.执行筛选 data.Excel数据库, sql End Sub
    • 筛选方式
      • 筛选方式是指结果的样式 1 筛选全部字段 '*表示全部字段 Sub 筛选全部字段() Dim sql As String Dim data As New 数据库 sql = "Select * from ChuKu" data.执行筛选 data.Access数据库, sql End Sub 2 筛选指定字段 '在from前面列出要显示的所有字段,如果要跳过的用"""" Sub 显示指定字段() Dim sql As String Dim data As New 数据库 sql = "Select """",出库日期,"""",物品代码,"""",规格,单位 from ChuKu" data.执行筛选 data.Access数据库, sql End Sub 3 筛选不重复的 'Distinct 字段名 筛选不重复的记录 Sub 不重复筛选() Dim sql As String Dim data As New 数据库 sql = "Select Distinct """",物品代码 from ChuKu" data.执行筛选 data.Access数据库, sql End Sub 4 筛选前N个 'TOP N 只显示前N个记录 Sub 筛选前10个() '按个数筛选 Dim sql As String Dim data As New 数据库 sql = "Select top 10 * from ChuKu" data.执行筛选 data.Access数据库, sql End Sub 'Top N percent 可以显示前百分之N的记录 Sub 筛选百分之N() '按百分比筛选 Dim sql As String Dim data As New 数据库 sql = "Select top 30 Percent * from ChuKu" data.执行筛选 data.Access数据库, sql End Sub 5 格式化显示的结果 '可以对筛选的字段用函数进行进一步的处理和格式化 Sub 格式化字段() '按百分比筛选 Dim sql As String Dim data As New 数据库 sql = "Select ID,Format(出库日期,""yyyy-mm-dd"") from ChuKu" data.执行筛选 data.Access数据库, sql End Sub 6 对筛选后的结果排序 Sub 排序() ' 'Desc降序 'Asc升序 Dim sql As String Dim data As New 数据库 sql = "Select * from ChuKu Order by 出库日期 asc,销售单价 desc" data.执行筛选 data.Access数据库, sql End Sub Sub 筛选销售数量前10() ' Dim sql As String Dim data As New 数据库 sql = "Select Top 10 * from ChuKu Order by 出库日期 asc,销售单价 desc" data.执行筛选 data.Access数据库, sql End Sub '7 分组显示 'Group by 可以配合函数进行分组求和,分组求最大值等. Sub 分组() ' Dim sql As String Dim data As New 数据库 sql = "Select """","""",物品代码,"""","""","""",sum(出库数量) from ChuKu group by 物品代码" data.执行筛选 data.Access数据库, sql End Sub Sub 按条件显示分组记录() ' Dim sql As String Dim data As New 数据库 sql = "Select """","""",物品代码,"""","""","""",sum(出库数量) from ChuKu group by 物品代码 HAVING sum(出库数量)>=3" data.执行筛选 data.Access数据库, sql End Sub
    • SQL函数应用
      • 1 SUM函数求和,count计数 Sub 求和() Dim sql As String Dim data As New 数据库 sql = "Select sum(出库数量),count(出库数量) from ChuKu where 物品代码='0270001'" data.执行筛选 data.Access数据库, sql End Sub 2 left,right,mid,instr,format文本函数 Sub 文本() Dim sql As String Dim data As New 数据库 sql = "Select 物品代码, ""左三位:"" & left(物品代码,3),right(物品代码,4),mid(物品代码,2,2),instr(物品代码,""1"") from ChuKu" data.执行筛选 data.Access数据库, sql End Sub 3 year,month,day,datediff,DateSerial日期函数 Sub 日期() Dim sql As String Dim data As New 数据库 sql = "Select 出库日期, year(出库日期),month(出库日期),day(出库日期),DateDiff(""m"",出库日期,now) from ChuKu" data.执行筛选 data.Access数据库, sql End Sub 4 max,min,first,last 最值函数 Sub 最小值() Dim sql As String Dim data As New 数据库 sql = "Select 物品名称,min(销售金额) from ChuKu group by 物品名称" data.执行筛选 data.Access数据库, sql End Sub Sub 最新值() Dim sql As String Dim data As New 数据库 sql = "Select 物品名称,last(销售金额) from ChuKu group by 物品名称" ’最后一条记录 data.执行筛选 data.Access数据库, sql End Sub
    • 多表查询
      • 类模块：类1 Sub 执行筛选(sq, Rg As String) Dim conn As New Connection With ActiveSheet 'Sheets("sheet1") .Range(Rg).Resize(100, 7) = "" conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName .Range(Rg).CopyFromRecordset conn.Execute(sq) End With conn.Close Set conn = Nothing End Sub 表1.  表二  'Union (AlL) 多个select查询结果合并在一起，所有记录合并 Sub 合并工作表数据() Dim data As New 类1 Dim sql As String sql = "select * from [Sheet1$a:c] union all select * from [sheet2$a:c]" data.执行筛选 sql, "a2" End Sub  Sub 合并工作表数据2()‘重复数据不会合并 Dim data As New 类1 Dim sql As String sql = "select * from [Sheet1$a:c] union select * from [sheet2$a:c]" data.执行筛选 sql, "a2" End Sub  '查找两个表中相同的 'Select 字段 from 表1,表2 where 表1.字段=表2.字段 Sub 列出相同() Dim data As New 类1 Dim sql As String sql = "select [Sheet1$a:c].* from [Sheet1$a:c],[Sheet2$a:c] where [Sheet1$a:c].类别=[Sheet2$a:c].类别" data.执行筛选 sql, "a2" End Sub  'Select 字段 from 表1 Inner Join 表2 on 条件 Sub 列出相同2() Dim data As New 类1 Dim sql As String sql = "select [Sheet1$].*,[sheet2$].库别 from [Sheet1$] Inner Join [sheet2$] on [Sheet1$].类别=[sheet2$].类别" data.执行筛选 sql, "a2" End Sub  '两表汇总 Sub 汇总() Dim data As New 类1 Dim sql As String Dim sq As String sql = "select * from [sheet1$a:c] union all select * from [sheet2$a:c]" sq = "select 类别,sum(数量),sum(金额) from (" & sql & ") group by 类别" data.执行筛选 sq, "a2" End Sub  Sub 合并() Dim data As New 类1 Dim sql As String sql = "select [Sheet1$].*,[sheet2$].库别 from [Sheet1$] left Join [sheet2$] on [Sheet1$].类别=[sheet2$].类别" data.执行筛选 sql, "a2" End Sub  'JOIN: 如果表中有至少一个匹配，则返回行 'LEFT JOIN: 即使右表中没有匹配，也从左表返回所有的行 'RIGHT JOIN: 即使左表中没有匹配，也从右表返回所有的行 'FULL JOIN: 只要其中一个表中存在匹配，就返回行,可惜的是在EXCEL VBA中不支持