'第一章VBA基础知识
Sub 属性()
MsgBox Sheet1.Name '工作表1的名称
MsgBox Sheet1.Range("a1").Value '工作表1中单元格A1的值
End Sub
'VBA对象属性的赋值
Sub 属性赋值()
Sheet1.Name = "&文本连接"
Sheet1.Range("a1") = "&文本连接"
End Sub
'1.常量：常量是定义了之后就不做变化了。
’ 常量定义格式：Const 常量名= 常量表达式
Sub 常量()
Const pi = 3.145926 '定义常量pi=3.14
End Sub
'2.变量:在定义之后还能再次赋值
'变量定义格式：Dim 变量 As 变量类型
Sub 变量()
Dim a As Integer '定义a为变量
a = 100 '赋值a=100
End Sub
'3.常量变量应用
Sub 应用()
Const pi = 3.1415926 '定义常量pi=3.14
Dim a As Integer '定义a为变量
a = 200 '赋值a=200
MsgBox pi * a '弹出pi×a的结果
End Sub
'3.注意事项
'A.VBA允许使用未定义的变量，默认是变体变量(Variant)
'B.变量的强制声明：Option Explicit
'4.变量名的命名规则
'以字母开头
'不能用保留字
'不超过 255 个字符。
'同一范围内必须是唯一
'-------------------------------------------------------------------
'1.VBA中的常见数据类型：
’ 类型 注释 简写 占用内存
’ Integer 整型 % 2Byte
’ Single 单精度 ! 4Byte
’ Double 双精度 # 8Byte
’ Long 长整型 & 4Byte
’ String 字符型 $ 定长或变长( 变长字符串最多可包含大约 20 亿 ( 2^31)个字符。 定长字符串可包含 1 到大约 64K ( 2^16 ) 个字符。)
’ Currency 货币型 @ 8Byte
'--------------------------------------------------------------------
Sub 数据类型()
Dim a As Integer '定义a为整型
Dim b% '定义b为整形（简写）
End Sub
Sub 多数据类型声明()
Dim a As Integer, b As Single, c As String '定义a为整型，b为单精度，c为字符型
Dim d%, e!, f$ '定义a为整型，b为单精度，c为字符型（简写）
End Sub
'VBA中的IF条件判断语句，就像函数中的IF一样
'IF可单条件，也可多条件。
'--------------------------------------------------------------------
Sub IF条件判断之单条件1()
Dim a%, b% '定义变量
a = 2
b = 2
If a = b Then MsgBox "相等" '如果a=b就弹窗相等，否则
End Sub '退出程序
Sub IF条件判断之单条件2()
Dim a%, b%
a = 2
b = 2
If a = b Then '如果a=b，然后
MsgBox "相等" '弹窗提醒相等
End If '结束if语句
End Sub
Sub IF条件判断之单条件3()
Dim a%, b%
a = 2
b = 2
If a = b Then '如果a=b，然后
MsgBox "相等" '弹窗相等
Else '否则
MsgBox "不相等" '弹窗不相等
End If '结束if语句
End Sub
Sub IF条件判断之多条件等级划分()
If Sheets("宏测试").Range("b1") >= 90 Then '如果B1单元格>90然后
Sheets("宏测试").Range("b2") = "优秀" 'b2单元格内容填充优秀
ElseIf Sheets("宏测试").Range("b1") >= 80 Then '如果B1单元格>80然后
Sheets("宏测试").Range("b2") = "良好" 'B2单元格内容填充良好
ElseIf Sheets("宏测试").Range("b1") >= 70 Then '如果B1单元格>70然后
Sheets("宏测试").Range("b2") = "中等" 'B2单元格内容填充中等
Else '否则
Sheets("宏测试").Range("b2") = "较差" ' B2单元格内容填充较差
End If '结束if语句
End Sub
'VBA中的IiF函数与工作表函数（IF）的语法一致
Sub IIF函数应用()
Cells(2, 3) = IIf(Cells(1, 2) > 80, "优秀", "不优秀") '如果单元格B1的值大于80，单元格C2就填充优秀，否则填充不优秀
End Sub
’ if函数总结
’ 1.单行形式1（If…Then）
’ If 条件判断 Then 条件成立结果
’ 注意 在单行形式中，按照 If…Then 判断的结果也可以执行多条语句。
’ 所有语句必须在同一行上并且以冒号分开。
’ 例子:
Sub 单行if1()
If 1 > 10 Then a = a + 1: b = 1 + a: c = 1 + b
End Sub
’ 2. 单行形式1（If 条件判断 Then 条件成立 Else 条件不成立）
’ 例子:
Sub 单行if2()
If 1 > 1 Then MsgBox "yes" Else MsgBox "no"
End Sub
’
’ 3.块形式（If…Then…End）
’ If 条件判断 Then
’ 条件成立结果
’ End If
’ 例子:
Sub test3()
If 11 > 10 Then
a = 1 + a
b = 1 + a
c = 1 + b
End If
End Sub
’
’
’ 4.块形式的If嵌套
’ If 条件判断 Then
’ 成立时的结果
’ ElseIf 条件判断 Then
’ 成立时的结果
’ ……
’ Else
’ 不成立时的结果
’ End If
’ 例子:
’ Sub 等级判断()
’ If Sheet1.Range(“b1”) >= 90 Then
’ Sheet1.Range(“b2”) = “优”
’ ElseIf Sheet1.Range(“b1”) >= 80 Then
’ Sheet1.Range(“b2”) = “良”
’ ElseIf Sheet1.Range(“b1”) >= 70 Then
’ Sheet1.Range(“b2”) = “中”
’ Else
’ Sheet1.Range(“b2”) = “差”
’ End If
’ End Sub
Sub 自学()
If 1 > 1 Then MsgBox 1 Else MsgBox 0
End Sub
Sub 自学2()
If 2 > 1 Then MsgBox 1 Else MsgBox 0
End Sub
Sub 自学3()
If 1 > 1 Then MsgBox 2 Else MsgBox 1
End Sub
Sub 自学4()
If 2 > 1 Then
MsgBox 2
End If
End Sub
Sub 自学5()
If 1 > 5 Then
MsgBox 1
ElseIf 1 > 4 Then
MsgBox 1
ElseIf 1 > 3 Then
MsgBox 1
ElseIf 1 > 3 Then
MsgBox 1
Else: MsgBox "无输出值"
End If
End Sub
'Select Case 语句 根据表达式的值，来决定执行几组语句中的其中之一。
Sub select单条件判断()
i = 1
Select Case i 'select表达i
Case Is > 0 '如果case值大于0
MsgBox "正数" '就弹窗正数
Case Else '否则
MsgBox "负数" '就弹窗负数
End Select '结束select语句
End Sub
Sub select多条件判断()
Select Case Sheets("宏测试").[d1].Value 'select表达工作表1中D1单元格的值
Case "A" '如果等于A
Sheets("宏测试").[a3] = "A型血的你，是个不怎么样的人！" 'A3单元格填充。。。
Case "B" '如果等于B
Sheets("宏测试").[a3] = "B型血的你，也是个不怎么样的人~" 'A3单元格填充。。。
Case "AB" '如果等于AB
Sheets("宏测试").[a3] = "AB型血的你，是个更不怎么样的人~" 'A3单元格填充。。。
Case "O" '如果等于O
Sheets("宏测试").[a3] = "O型血的你，还是不错的！" 'A3单元格填充。。。
Case Else '否则
Sheets("宏测试").[a3] = "没有这种型血，看来你 是个最不怎么样的人~！" 'A3单元格填充。。。
End Select '结束select语句
End Sub
'do …loop 循环语句，直到满足某个条件
Sub 基本示例()
Dim a% '定义变量a
Do 'do循环起始
a = a + 1 'a=a+1
If a > 10 Then '如果a>10，然后
MsgBox a & "终于大于10" '弹窗a终于大于10
Exit Do '退出do循环
End If '结束if语句
Loop 'do循环结尾
End Sub
Sub 基本示例2()
Dim rs% '定义变量rs
rs = 1 'rs赋值为1
Do 'do循环开始
rs = rs + 1
If rs > 10 Then '如果rs的值>10，然后
Exit Sub '退出程序
Else '否则
If Worksheets("宏测试").Cells(rs, 2) >= 90 Then Worksheets("宏测试").Cells(rs, 3) = "√"
'如果单元格的值>=90，就填充√
End If '结束if语句
Loop 'do循环结尾
End Sub
Sub 循环语句dowhile()
Dim rs As Integer '定义变量
rs = 2
Do While Cells(rs, 2) <> "" '当单元格不等于空时
If Worksheets("宏测试").Cells(rs, 2) >= 90 Then Cells(rs, 3) = "√" '如果单元格值>=90，然后填充√
rs = rs + 1 '赋值rs=rs+1
Loop 'do循环结尾
End Sub
'do until…loop
Sub 循环语句untilDOLOOP2()
Dim rs As Integer '定义变量
rs = 2
Do Until Worksheets("宏测试").Cells(rs, 2) = "" '循环直到单元格为空为止，才结束
If Worksheets("宏测试").Cells(rs, 2) >= 90 Then Cells(rs, 3) = "√" '如果单元格值>=90，然后另一个单元格填充√
rs = rs + 1 '赋值rs=rs+1
Loop '循环
End Sub
'实例-隔行填色
Sub 隔行填色()
Dim rs As Integer '定义变量
rs = 2 '赋值rs=2
Do Until Worksheets("宏测试").Range("a" & rs) = "" '循环直到单元格为空
Worksheets("宏测试").Range("a" & rs & ":g" & rs).Interior.ColorIndex = 7 '区域填充颜色
rs = rs + 2 '赋值rs=rs+2
Loop '循环结尾
End Sub
Sub 外观()
With Cells(1, 1)
.Value = 1
.NumberFormatLocal = "0.00" '设置单元格数字格式为0.00
gs = .NumberFormatLocal '获取单元格的数字格式样式
.ClearFormats '清除单元格数字格式
.Borders.LineStyle = xlContinuous '添加框线
.Interior.ColorIndex = 28 '添加单元格底纹颜色
.Font.Size = 10 '单元格字体大小为10
.Font.Bold = 1 '单元格字体加粗
.Font.color = RGB(255, 0, 255) '设置字体颜色
.Font.Color = vbRed '重复文字改为红色
.Font.Color = vbBLACK '重复文字改为黑色
.Font.Name = "微软雅黑" '设置单元格字体
.HorizontalAlignment = xlCenter '单元格字体居中
Range("A1:B1").Merge '合并单元格
Range("A1:B1").UnMerge '取消合并单元格
Rows("1:1").EntireRow.AutoFit '自动调节第一行的行高
Columns("a:a").EntireColumn.AutoFit '自动调节第一列的列宽
Cells.EntireColumn.AutoFit '自动调节所有单元格列宽
Cells.EntireRow.AutoFit '自动调节所有单元格行高
End With
End Sub
'while与until不但可以放在DO后面，也可以放在LOOP后面
'事实上有时在循环的最后一行进行判断，更具有意义
Sub doloop的最后判断循环()
Dim pss$, i! '定义变量
Do 'do循环
i = i + 1 '赋值i=i+1
If i > 3 Then Exit Do '如果i>3，然后退出do循环
pss = InputBox("请输入密码") '赋值pss=弹窗输入的内容
Loop While pss = "123" '循环直到pss=123
End Sub
'Do [{While | Until} 表达式]总结
'[执行的一条或多条语句]
'[Exit Do]
'[执行的一条或多条语句]
'Loop
'---------------------------------------------------------------------------------
'while：当这个条件为True时就 循环
'until：直到这个条件为True时就 跳出循环
'---------------------------------------------------------------------------------
'或者可以使用下面这种语法:
'Do
'[执行的一条或多条语句]
'[Exit Do]
'[执行的一条或多条语句]
'Loop [{While | Until}表达式]
'---------------------------------------------------------------------------------
'用Do…Loop循环要注意的几点:
'1. While与Until是放在Do后面还是Loop后面，取决于是先判断再循环，还是先循环再判断。前者则在Do后面，后者则在Loop后面。
'2. 可以在Do…Loop中的任何位置放置任意个数的 Exit Do 语句，随时跳出 Do…Loop 循环。
'3. Do…Loop + If…Then + Exit Do 通常结合使用.
'4. 如果 Exit Do 使用在嵌套的 Do…Loop 语句中，则 Exit Do 会将控制权转移到 Exit Do 所在位置的外层循环。
'---------------------------------------------------------------------------------
Sub test()
Dim a%
Do
a = a + 1
If a > 5 Then
MsgBox a & "终于大于5"
Exit Do
End If
Loop
End Sub
Sub test2() '注意这是一个死循环，按F8运行（中止死循环：ctrl+暂停键）
Do
b = b + 1
Do
a = a + 1
If a > 3 Then MsgBox "即将跳出内层循环": Exit Do
Loop
MsgBox "即将进行外层循环"
Loop
End Sub
Sub 练习()
Do
a = a + 1
If a > 5 Then
MsgBox a & "终于大于5"
Exit Do
End If
Loop
End Sub
'当需要处理集合成员时，一般会用for each…next,实际上就是处理对象
Sub foreachnext循环1()
Dim rng As Range, n! '定义变量
For Each rng In Worksheets("宏测试").Range("a2:a10") '取a2:a10中的每个单元格
If rng = "A1" Then rng.Interior.ColorIndex = 3 '如果rng=A1，然后rng单元格填充底色
Next 'for循环结尾
End Sub
Sub foreachnext循环2()
Dim wsh As Worksheet, n As Byte, m As String '定义变量
For Each wsh In Worksheets '取当前工作表集合中的每个成员
n = n + 1
Worksheets("宏测试").Cells(n, 3) = wsh.Name '单元格填充工作表的名称
Next 'for循环结尾
End Sub
'FOR…NEXT也是循环语句，与之前的DO…LOOP不同之处在于，for next有一个内置计数器
Sub fornext循环2()
Dim i!, j! '定义变量
For i = 100 To 1 Step -2 '循环i的值从100到1，步进值为-2
j = j + i '赋值j=j+1
Next 'for循环结尾
MsgBox j '弹窗提示j
End Sub
Sub fornext循环()
Dim rng! '定义变量
For rng = 2 To 16 'for循环rng的值从2到16
Worksheets("测试").Cells(rng, 4) = Worksheets("测试").Cells(rng, 2) * Worksheets("测试").Cells(rng, 3)
'单元格的值等于另外两个单元格值相乘的结果
Next 'for循环结尾
End Sub
Sub 九九乘法表制作()
Dim a!, b! '定义变量
For a = 1 To 9 'for循环从1到9
For b = 1 To 9 'for循环从1到9
If b > a Then '如果b>a，然后
Worksheets("测试").Cells(a, b) = "" '单元格值填充空值
Else '否则
Worksheets("测试").Cells(a, b) = a & "×" & b & "=" & a * b '单元格填充。。。
End If '结束if语句
Next '中间for循环结尾
Next '开头for循环结尾
End Sub
'For…NEXT小结与实例
'For…Next 语句
'以指定次数来重复执行一组语句
'-----------------------------------------------------
'语法
'For 计数变量 = 初始值 To 终止值 [Step 步长值]
'[执行的一条或多条语句]
'[Exit For]
'[执行的一条或多条语句]
'Next [计数变量]可以忽略不写
'-----------------------------------------------------
'1.循环中可以在任何位置放置任意个 Exit For 语句，随时退出循环。
'2.Exit For与 If…Then经常一起使用，目的是：找到符合条件后，跳出循环，而不必再进行不必要的循环。
Sub test11()
For i = 1 To 16
If Cells(i, 1) = "2班" Then Exit For '找到2班的起始位置
Next i
For j = 1 To 16
If Cells(j, 1) = "3班" Then Exit For '找到3班起始位置
Next j
MsgBox "2班的人数为:" & j - i '3班起始位置-2班起始位置
End Sub
'3.可以将一个 For…Next 循环放置在另一个 For…Next 循环中，组成嵌套循环。
’ For I = 1 To 10
’ For J = 1 To 10
’ For K = 1 To 10
’ …
’ Next K
’ Next J
’ Next I
Sub 理解计数变量的运行()
For i = 1 To 2
For j = 1 To 3
k = "外层的第" & i & "次的，内层的第" & j & "次"
Next j
Next i
End Sub
'exit是退出当前语句
'1.Exit Do
'2.Exit For
'3.Exit Function
'4.Exit Sub
Sub exitfor退出()
Dim i!
For i = 2 To 7 'for循环从2到7
If Worksheets("测试").Cells(i, 1) = "田七" Then '如果单元格值为田七，然后
Exit For '退出for循环
End If '结束if语句
Next i 'for循环结尾
MsgBox "第一个（田七）的位置在" & i & "行" '弹窗提示第一个田七的位置在第i行
End Sub
'end结束一个过程或块。
'End
'End Function
'End If
'End Select
'End Sub
Sub aa()
i = 1
End
Exit Sub '结束程序（可提前结束整个程序）
j = 1
End Sub
'GoTo line无条件地转移到过程中指定的行。
'注意 太多的 GoTo 语句，会使程序代码不容易阅读及调试。
'尽可能使用结构化控制语句(Do…Loop、For…Next、If…Then…Else、Select Case)。
Sub gotoline()
Dim str$ '定义变量
line: '定义line行
str = InputBox("请录入用户名！") '定义变量str的值为弹窗输入的值
If str <> "admin" Then GoTo line '如果str的值不是admin，然后就跳转line行
End Sub
'go sub…return
Sub gotoreturn()
Dim i!
For i = 2 To 10 'for循环从2到10
If Worksheets("宏测试").Range("a" & i) > 1 / 3 Then GoSub 100 '如果单元格值>1/3，然后跳转100行
Next i 'for循环结尾
Exit Sub '退出程序
100: '定义100行
Worksheets("宏测试").Range("b" & i) = "迟到" '如果单元格值为迟到
Return '返回至跳转语句之前
End Sub
Sub onerrorresume()
Dim i!
On Error Resume Next '当错误的时候继续执行下去
For i = 2 To 8 'for循环从2到8
Cells(i, 4) = Cells(i, 3) + Cells(i, 2) '单元格值等于另外两个单元格值相加
Next i 'for循环结尾
End Sub
'On Error GoTo当错误的时候去哪儿?
Sub onerrorgoto()
On Error GoTo 100 '当发生错误的时候跳转100行
For i = 2 To 8 'for循环从2到8
k = Worksheets("宏测试").Cells(i, 2) + Worksheets("宏测试").Cells(i, 3) '赋值k=
Next i 'for循环结尾
100: '定义100行
MsgBox "对不起，错误发生在第" & i & "行" '弹窗提醒，对不起错误发生在第i行
End Sub
'with 语句 ,当对某个对象执行一系列的语句时，不用重复指出对象的名称。
Sub with语句1()
a = Range("a1").Address
b = Range("a1").Parent.Name
Range("a1") = "1234"
End Sub
Sub with语句2()
With Range("a1") 'with赋值
a = .Address '.代表了with后面的值
b = .Parent.Name
.Value = "1234"
End With
End Sub
Sub with嵌套1()
Range("a1").Value = "Who am i ?" '单元格值为who am i
Range("a1").Parent.Name = "Hello World" '单元格所在的sheet表名命名为
Range("a1").Font.Size = 20 '单元格字体大小为20
Range("a1").Font.Bold = True '单元格字体加粗
End Sub
Sub with嵌套2()
With Range("a1")
.Value = "Who am i ?" '单元格的内容为who am i
.Parent.Name = "Hello World" '单元格所在的工作表的名称为hello world
With .Font 'with赋值单元格格式，即目前.代表range("A1").font
.Size = 20 '文字尺寸为20
.Bold = True '字体为黑体
End With '结束with赋值
End With '结束with赋值
End Sub
'在VBA中也可以像在工作中一样录入公式
Sub VBA中的做法()
Dim i%
For i = 1 To 10
Range("c" & i) = Range("a" & i) + Range("b" & i)
Next
End Sub
Sub 普通公式()
Cells(1, 3) = "=a1+b1"
End Sub
Sub 批量计算()
Dim i As Integer
For i = 1 To 10
Cells(i, 4) = "=a" & i & "+b" & i '将D1:D10填充公式，相当于D1填充公式后下拉
Next
End Sub
Sub 数组公式()
Range("e1:e10").FormulaArray = "=a1:a10+b1:b10"
End Sub
Sub 带工作表函数的计算()
Dim i As Integer
For i = 1 To 10
Cells(i, 4) = "=sum(a" & i & ":b" & i & ")"
Next i
End Sub
Sub 公式带引号的计算()
Cells(12, 1) = "=COUNTIF(A1:A10,"">9"")"
Cells(12, 2) = "=sum(INDIRECT(""a1:a10""))"
End Sub
'借用工作表函数
Sub 运用工作表函数()
MsgBox Application.WorksheetFunction.CountIf(Range("a1:a10"), "钢笔") '方法一：统计单元格区域A1:A10值为钢笔的个数
MsgBox WorksheetFunction.CountIf(Range("a1:a10"), "钢笔") '方法二：统计单元格区域A1:A10值为钢笔的个数
MsgBox Application.CountIf(Range("a1:a10"), "钢笔") '方法三：统计单元格区域A1:A10值为钢笔的个数
End Sub
'VBA函数
Sub VBA函数()
MsgBox VBA.Format(Range("b1"), "yyyy年m月d日") 'format定义格式，方法一：将B1单元格值转化为日期格式。
MsgBox Format(Range("b1"), "yyyy年m月d日") '方法二：将B1单元格值转化为日期格式。
End Sub
'自定义函数
Function SEX(rng As Range) '自定义函数声明
SEX = IIf(Mid(rng, 15, 3) Mod 2, “男”, “女”) '设置一个公式，提供变化值rng，公式名为SEX
End Function
'定义: 运算符是代表VBA某种运算功能的符号?
'1）赋值运算符 :=
'2）数学运算符: &(字符连接符)、+(加)、-（减）、Mod（取余）、\（整除）、*（乘）、/（除）、-（负号）、^（指数）
'3）逻辑运算符:Not（非）、And（与）、Or(或)、Xor(异或)、Eqv(相等)、Imp(隐含)
'4）关系运算符: = （相同）、<>（不等）、>（大于）、<（小于）、>=（不小于）、<=（不大于）、Like
Sub mods()
a = 4 ^ 2
End Sub
'like用来比较两个字符串。
Sub likess()
a = 1 Like "[!2]" '1是否与跟2不同的任何单一字符一样，返回true
End Sub
’ ?任何单一字符
’ * 零个或多个字符。
’ # 任何一个数字 (0–9)。
’ [charlist] charlist.中的任何单一字符?
’ [!charlist] 不在 charlist 中的任何单一字符。
'*### 8 最后三个是数学
’ E 9 包含E字
’ NED# 4 以NED开始，然后接一个数字
'[A-Z][A-Z]### 2 两个任意字母开始，再接三个任意数字
'??? 5 编号为四个字符
Sub a1()
a = "admin" Like "Admin" '区分大小写 'like与LIKE不一样，返回false
End Sub
Sub a2()
b = "abc" Like "a?c" ' 通配符运用 '返回true
b2 = "abc" Like "???" '返回true
End Sub
Sub a3()
c = "excel函数" Like "*函*" '返回true
End Sub
Sub a4()
d = 88 Like "##" '返回true
End Sub
Sub a5()
e = "a" Like "[a-z]" '返回true
f = 8 Like "[!1-7]" '返回true
g = 8 Like "[1-4,6-9]" '返回true
End Sub
Sub like用法示例()
For j = 2 To 6 'for循环从2到6
For i = 2 To 14 '第二个for循环从2到14
If Cells(i, "a") Like Cells(j, "e") Then n = n + 1 '如果单元格1等于单元格2，就n=n+1，否则直接下一步
Next '向上循环直到i=14
Range("f" & j) = n '赋值单元格值为n
n = 0 '将n归零
Next '接着向上循环
End Sub
Option Explicit
Sub 测试()
Dim rng As Range, rngs As Range, k%, a, b '申明变量
For Each rng In [a2:a6] '在A2：A6区域中的每一个单元格
a = rng.Value '将单元格rng的值赋予a
For Each rngs In [b2:b4] '在A2：A6区域中的每一个单元格
b = rngs.Value '将单元格rngs的值赋予b
If a = b Then '如果a=b
GoTo 100 '说明a这个值在B列中存在，就直接跳转100行
End If '结束if语句
Next rngs '如果循环未结束，向上接着循环，取B列的下一个单元格
k = k + 1 '赋值k=k+1,k无赋值，默认初始值为0
Cells(k + 1, "c") = rng '单元格C列填入未盘点编码
100: '100行
Next rng '如果循环未结束，向上接着循环，否则下一步
End Sub
Sub 未盘点编码()
Dim rng As Range, rngs As Range, k%
For Each rng In [a1:a796] '在A1:A769中的每一个单元格
For Each rngs In [g1:g175] '在G1:G175中的每一个单元格
If rngs = rng Then '如果单元格相等，然后
GoTo 100 '直接跳转100行
End If '否则结束if语句
Next rngs '循环未结束，返回循环，否则下一步
k = k + 1 '赋值
Cells(k, "h") = rng 'K列按顺序赋值=rng的值
100: '100行
Next rng '循环未结束，返回循环，否则下一步
End Sub
'第二章 工作簿与工作表
Sub 拆分到工作簿()
Dim wk As Workbook, ss$, k% '定义变量
Application.DisplayAlerts = False '关闭屏幕闪烁
For Each sht In Workbooks("月报").Sheets '在工作簿（月报）所有sheets表中的每一个工作表
Set wk = Workbooks.Add '新打开（或者称为新建，但是并未命名，也未定义位置）一个工作簿
k = k + 1 '赋值k=k+1
Workbooks(1).Sheets(k).Copy Workbooks(2).Sheets(1) '将工作簿1中的第k个工作表复制 到工作簿2的第1个工作表中
ss = ThisWorkbook.Path & "\" & sht.Name & ".xlsx" '将ss赋值为月报工作簿目录下，且工作簿名称为sht工作表的名字
wk.SaveAs ss '将wk保存，确定位置及工作簿名
wk.Close '关闭wk工作簿
Next '循环未结束，接着向上循环，将工作簿（月报）中的下一个工作表拆分成工作簿
Application.DisplayAlerts = True '打开屏幕闪烁
MsgBox "拆分工作簿完成！" '弹出拆分工作簿完成！
End Sub
'1、工作簿（Workbooks）
’ Workbooks（N）第N个工作簿
’ Workbooks (“工作簿名”)
’ ActiveWorkbook 活动工作簿
’ ThisWorkBook '代码所在工作簿
'2、工作表（Worksheets）
'Sheets(N) 第N个工作表
'Sheets(“工作表名”)
'SheetN 第N个工作表
'ActiveSheet 活动工作表
'worksheets 与 Sheets的区别
'3、单元格（cells）
'Range (“单元格地址”)
'Cells(行号,列号)
'[A1]单元格简写
'Activecell 活动单元格
'Selection 当前被选取的区域
Sub 工作簿名称表示法()
MsgBox Workbooks("excel公式大全.xlsm").Parent '返回工作簿对象的父对象。
End Sub
Sub 工作簿引索号表示法()
MsgBox Workbooks(2).Name '返回工作簿的名称
End Sub
Sub 窗口表示法()
MsgBox Worksheets.Count '返回当前excel工作表打开的个数
MsgBox Worksheets(1).Name '返回第1个工作表的名称
End Sub
Sub 工作表实例worksheets法()
Dim i
For i = 1 To Worksheets.Count 'for循环从1到工作表的数量
Sheets("宏测试").Cells(i, 1) = Worksheets(i).Name '名称为宏测试的工作表中的单元格第i行第一列内容为第i个工作表的名称
Next
End Sub
Sub 工作簿实例windows方法()
Dim i
For i = 1 To Windows.Count 'for循环从1到工作簿的数量
Sheets("宏测试").Cells(i, 2) = Windows(i).Parent.Name '名称为宏测试的工作表中的单元格第i行第一列内容为第i个工作簿的名称
Next
End Sub
'thisworkbook当前工作簿，代码所在工作簿
'activeworkbook活动工作簿，被激活的工作簿
Sub 当前与活动工作簿区别实例()
MsgBox ThisWorkbook.Name & "---" & ActiveWorkbook.Name '代码所在的工作簿—活动工作簿
End Sub
Sub 运用()
MsgBox ThisWorkbook.Path & Chr(10) & ThisWorkbook.FullName '当前工作簿的路径+空格＋当前工作簿包含簿名的路径
End Sub
Sub 验证当前工作簿是否已打开()
Dim wk As Workbook, a '定义变量wk未工作簿，a为变量
For Each wk In Workbooks '遍历所有工作簿中的每一个wk
a = wk.Name 'a=wk工作簿的名称
If wk.Name = "excel公式大全.xlsm" Then '如果wk工作簿的名称为Excel公式大全.xlsm 然后
wk.Activate '激活wk工作簿
MsgBox "已激活工作簿" & wk.Name '弹窗提示已激活工作簿
Exit Sub
End If
Next wk '否则for循环
MsgBox "没有发现工作簿：excel公式大全.xlsm" '循环结束弹窗没有发现工作簿
End Sub
Sub 合并相同内容单元格()
Application.DisplayAlerts = False '关闭弹窗提示
Set ha = ActiveCell '赋值ha为活动单元格
For Each rng In Selection 'for循环每一个选中的单元格
If rng <> rng.Offset(1) Then '如果当前单元格不等于右侧的单元格
ha.Resize(ha.Count + 1).Merge
Set ha = rng.Offset(1)
Else
Set ha = Union(ha, rng)
End If
Next
Application.DisplayAlerts = True
End Sub
Sub 不重复的姓名()
Dim i%, j%, d As Object
Set d = CreateObject("scripting.dictionary")
arr = Selection
For i = 1 To UBound(arr)
For j = 1 To 2
If arr(i, j) <> "" Then
d(arr(i, j)) = d(arr(i, j)) + 1
End If
Next j
Next i
ActiveCell.Resize(d.Count) = Application.Transpose(Array(d.keys, d.items))
End Sub
'方法：实际上就是对对象的操作，它是一种动作，一种行为。
Sub 选择方法()
Sheets("宏测试").Range("a1:a10").Select '选中宏测试工作表中的A1到A10区域
'注：如果单元格区域前没有写工作表名，则默认为活动工作表
End Sub
Sub 复制方法()
Sheets("宏测试").Sheet1.Range("a1:a10") = 1 '将1写入表一的a1:a10区域
Sheets("宏测试").Sheet1.Range("a1:a10").Copy Sheets("宏测试").Range("a1") '将a1:a10区域的值复制到a1
End Sub
Sub 删除方法()
Sheets("宏测试").Cells.Delete '清除整个工作表的内容
End Sub
'workbooks由当前所有在内存中打开的workbook对象组成
'向workbooks添加workbook对象
'1.新建工作簿
Sub 新建工作簿()
Dim wkb As Workbook '声明wkb为工作簿
Set wkb = Workbooks.Add '新建工作秒簿
wkb.SaveAs "c:\123.xls" '保存工作簿，输入保存位置和工作簿的名称
End Sub
'2.打开工作簿
Sub 打开工作簿()
Dim wkb As Workbook '申请wkb未工作簿
Set wkb = Workbooks.Open("c:\123.xls") '打开**位置下名称为**的工作簿
End Sub
'3.关闭工作簿
Sub 关闭()
Workbooks("123").Close True '关闭名称为123的工作簿
End Sub
'3.文件复制与删除
Sub 文件复制与删除()
FileCopy "c:\123.txt", "c:\321.txt" '复制路径1下的文件1，到路径2下，并且名称为对所有文件类型都起作用,并且可更改文件类型（更改后缀）
Kill "c:\321.txt" '关闭路径1下名为321的文件
End Sub
Sub 文件是否存在()
a = Dir("c:\123.xls") '遍历路径1下文件是否有文件名为a的文件
If a = "" Then '如果不存在，即a=""
MsgBox "不存在" '弹窗不存在
Else '否则
MsgBox "存在" '弹窗存在
End If '结束if语句
End Sub
Sub 打开指定目录下的所有文件()
Sub bianli()
Dim a As String '赋值a为文本型
a = Dir(ThisWorkbook.Path & “*.xls”) '赋值a=当前工作簿目录下的第一个xls文件
Do Until a = “” '循环，直到1=空值的时候
k = k + 1
Workbooks.Open (ThisWorkbook.Path & a) '打开指定路径的文件
a = Dir '赋值a=下一个xls文件
Loop '循环结束
End Sub
'在workbook对象中，有一个SHEETS集合,其成员是worksheet对象或chart对象。
'worksheets仅指的是工作表，而sheets包含图表，工作表，宏表等等
'VBA中，经常在工作表之间转换或者对不同工作表中的单元格区域进行操作.
'通常有下面几种方法:
Sub 直接使用工作表名称法()
MsgBox Worksheets(“我的工作表”).Name
MsgBox Sheets(“我的图表”).Name
End Sub
Sub 索引号表示法()
MsgBox Worksheets(1).Name '第几个工作表（仅工作表）
End Sub
Sub 工作表代码索引号表示法()
MsgBox Sheets(1).Name '第几个工作表（包含图表）
End Sub
Sub 直接取工作代码法()
MsgBox Sheet1.Name '(代码为sheet1的工作表)
End Sub
Sub 活动工作表()
MsgBox ActiveSheet.Name
End Sub
'注意：当工作簿包括工作表、宏表、图表等时，
' 使用索引号引用工作表如Sheets(1)与
' WorkSheets(1)引用的可能不是同一个表。
Sub 逐个返回所有工作表的名称()
For i = 1 To Sheets.Count 'for循环，从1到最后一个工作表
MsgBox Sheets(i).Name '弹窗工作表的名称
Next '循环
End Sub
Sub 遍历sheets下的所有对象()
For Each shs In Sheets 'for循环（包含图表）
k = k + 1 '赋值k=k+1
Cells(k, 1) = shs.Name '单元格值填充工作表的名字
Next
End Sub
Sub 遍历worksheets下的所有对象()
For Each shs In Worksheets '(不包含图表)
k = k + 1
Cells(k, 2) = shs.Name
Next
End Sub
Sub 工作表存在与否()
Dim sn$
For Each sht In Sheets 'for循环，所有的工作表
sn = sht.Name '赋值sn=工作表名
If sn = “宏测试” Then '如果工作表名为 “我的工作表”
MsgBox “存在” '弹窗存在
Exit Sub '退出程序
End If '结束if语句
Next 'for循环
MsgBox “不存在” '弹窗提醒不存在
End Sub
Sub 工作表存在与否1()
Dim sn$
For i = 1 To Sheets.Count 'for循环，从1到最后一个工作表
a = Sheets(i).Name '赋值a=第i个工作表的名字
If a = “我的工作表” Then '如果a=“我的工作表”,然后
MsgBox “存在” '弹窗提醒存在
Exit Sub '退出程序
End If '结束if语句
Next 'for循环
MsgBox “不存在” '弹窗"不存在"
End Sub
Option Explicit
' Sheets.Add 工作表增加方法
' 表达式.Add(Before, After, Count, Type)
' XlSheetType 常量之一：
' xlWorksheet 工作表
' xlChart 图表
' xlExcel4MacroSheet 宏表
' xlExcel4IntlMacroSheet 对话框
' 默认值为 xlWorksheet。
'-------------------------------------------------------------
Sub 新建sheets()
Sheets.Add '在当前活动工作表之前添加一个新工作表
Sheets.Add Sheets(“宏测试”) '在工作表abc之前添加一个新工作表
Sheets.Add , Sheets(“宏测试”) '在工作表abc之后添加一个新工作表
Sheets.Add after:=Sheets(“宏测试”) '与上一句相同
Sheets.Add Count:=2 '在活动工作表之前添加两个空白工作表
Sheets.Add , , 2 '在活动工作表之前添加两个空白工作表
Sheets.Add , , , xlChart '在活动工作表之前添加一个空白图表
Sheets.Add.Name = 123 '在活动工作表之前新建一个名称为123.表
End Sub
Sub 删除工作表()
Sheet(100).Delete
End Sub
'如果想批量新建工作表，可以结果循环来制作
Sub 新建1到12月份的工作表()
Dim j%
For j = 12 To 1 Step -1 'for循环从12 到1，步进值为-1
Sheets.Add.Name = j & “月” '添加新工作表，名称为j月，位置为活动工作表的前面
Next
End Sub
Sub 在最后一个工作表后添加工作表()
a = Worksheets.Count '赋值a=工作表的数量
Worksheets.Add , Worksheets(a) '在最后一个工作后添加一个工作表
ActiveSheet.Name = 123 '活动的工作表名称为123
End Sub
'删除工作表
Sub 删除sheet()
On Error Resume Next '如果出错跳转下一步（针对下面的所有程序，只要运行报错，立刻跳转下一步，只一次）
Application.DisplayAlerts = False '关闭屏幕闪烁
Dim i%
For i = 1 To 12 'for循环从1到12
Sheets(i & “月”).Delete '删除名称为i月的工作表
Next '循环
Application.DisplayAlerts = True '开启屏幕闪烁
End Sub
Option Explicit
'表达式.Move(Before, After)
'表达式.copy(Before, After)
Sub 移动()
Sheet1.Move , Sheet3 '将工作表1移动到工作表3之后
End Sub
Sub 复制()
Sheet1.Copy Sheets(Sheets.Count) '复制表1到最后一个工作表之前
End Sub
Sub 实例()
Dim i%, sth As Worksheet
For i = 1 To 12 'for循环从1到12
Set sth = Sheets.Add '赋值sth为新建的工作表
sth.Move after:=Sheets(Sheets.Count) '将sth移动到最后一个工作表之后
sth.Name = i & “月” '将sth命名为i月
Next '循环
End Sub
Option Explicit
'-------------------------------
'Worksheet.Select 方法
'选择对象
'Worksheet.Activate 方法
'使当前工作表成为活动工作表
'工作表的选择select与activate
'-----------------------------------
Sub 工作表选择()
''Sheet3.Select '不支持隐藏选取
Sheet3.Activate '支持隐藏选取
End Sub
Sub 快速选择所有工作表()
Worksheets.Select
Sheets.Select
End Sub
Sub 自定义选择()
Worksheets(Array(1, 3, 5)).Select '同时选择第1,3,5个工作表
End Sub
'----------------------------------------------------
'单元格对象在VBA中一个非常基础，同时也很重要的。
'它的表达方式也是非常的多样化。
'----------------------------------------------------
'Range 对象
'代表某一单元格、某一行、某一列、某一选定区域（该区域可包含一个或若干连续单元格区域），或者某一三维区域。
'Range ("文本型装单元格地址")
'range的常见写法
Sub rng()
Range(“a1”).Select '单元格
Range(“a:a”).Select '列
Range(“1:3”).Select '行
Range(“a1:b10”).Select '相邻区域
Range(“a1:d7,c4:e8”).Select '不相个邻区域
End Sub
'写法：Range ("文本型装单元格地址1","文本型装单元格地址2")
'range的变化写法
Sub rng变化()
Range(“a1:b10”).Select '一般写法
Range(“a1”, “b10”).Select '变化写法1
Range(Range(“a1”), Range(“b10”)).Select '变化写法2
Range(“a1”) = 123
End Sub
'注意：
'1.如果在range前没有指定工作表，则默认为活动工作表
'2.如果对象不是活动工作表（如活动图表），则会出现错误
Sub 单元格对象例子()
Debug.Print Range(“a:a”).Count '计数工作表最大的行数
Debug.Print Range(“1:1”).Count '计算工作表最大的列数
Debug.Print Application.CountA(Range(“a:a”)) '计算工作表已使用的行数
Debug.Print Application.CountA(Range(“1:1”)) '计算工作表已使用的列数
End Sub
'除了上一课节讲的range基本表示方法外，还有更多的变化写法
'1.range("地址区域").range("地址区域")
Sub 序号表示法()
Range(“b2:d4”).Range(“b2”).Select '相对引用的写法
'参照前一个range的左上单元格
End Sub
'2.range地址区域中支持变量
Sub range的变量支持()
Dim a%
a = 3
Range(“a” & a).Select
Range(“c3:e5”)(2).Select '选中单元格区域中的第2个单元格
End Sub
Sub 实例1动态选单元格或区域()
Dim i%
i = Application.CountA(Range(“c:c”)) '找到c列中已使用的最后一个单元格位置
Range(“c” & i).Select '选择C列最后一格
Range(“a1”, “c” & i).Select '选择A1到C列的最后一格（方法一）
Range(“a1:c” & i).Select '选择A1到C列的最后一格（方法二）
'小结：动态单元格区域的定位，可以应用到单据的保存等实际工作中
End Sub
'range区域中的每个单元格，我们也可以用索引号表示出来
'写法：range("单元格区域")(行号，列号)
Sub 索引号取出range的单元格()
'Range(“a1:c4”)(4).Select '引用顺序是：从左向右，从上到下选取
'Range(“b2:c4”)(3).Select '以前一个单元格区域为照
Range(“a1:c4”)(4.5).Select '当有小数时，则取整
'注意：如果索引号出现小数，则按照“四舍六入五单双”的“银行家舍入法”
End Sub
Sub 行列号定位()
Range(“a1:c4”)(3, 2).Select '利用行号与列号定位
Range(“a1:c4”)(1.5, 2.5).Select '行列号也可以使用小数
End Sub
'小结:
'1.这个索引值是参照前一个单元格区域左上单元格进行定位引用的
'2.索引值可以是正数，负数，零值，小数
Sub 大于等于2500的平增工资()
Dim rs%, rng%, lj&, k%
For rs = 1 To 60 'for循环从1到60
Range(“b2:c20”)(rs).Select '选中单元格区域中的第rs个单元格(就算rs值超出单元格区域，也会默认往下选择）
rng = Range(“b2:c20”)(rs) '赋值rng为选中单元格的值
If rng >= 2500 Then lj = lj + rng: k = k + 1 '如果rng的值大于2500，就赋值lj，k
Next rs '循环
MsgBox “大于等于2500的平均分为：” & Int(lj / k) '弹窗提醒
End Sub
'cells单元格引用法
'写法：cells(行号,列号)
Sub cells基本写法()
Cells(3, 4).Select '行列号均为数字
Cells(2, “c”).Select '行为数字，列为列标字母
Cells.Select '全选
End Sub
'cells可以像range一样可以参照前面的单元格位置
Sub 参照写法()
Range(“b3:f11”).Cells(2, 2).Select
Range(“b3:f11”).Cells(6).Select '从左到右，从上到下
Range(“b3:f11”)(6).Select '与上一句相等
End Sub
'注意：
'1.cells中的数字一样支持正数，负数，0值，小数(四舍六入五单双)
'2.cells不能像range一样可以引用一个区域，只能引用一个单元格
'cells还可以嵌套在range中
Sub 嵌套()
Range(Range(“b1”), Range(“f11”)).Select '这种嵌套方法写变量比较麻烦
Range(Cells(3, 2), Cells(11, 6)).Select '这种嵌套方法写变量比较方便
End Sub
Sub 动态引用行列区域()
Dim a%, b%
a = Application.CountA(Range(“a:a”)) '赋值a=a列非空单元格的数目
b = Application.CountA(Range(“1:1”)) '赋值b第一行非空单元格的数目
Range(Cells(1, 1), Cells(a, b)).Select '选中所有非空单元格
End Sub
'除了前面讲的range\cells单元格区域的表示方法还，还是一种简单的写法
'写法: [单元格地址] '注意：中括号中的单元格地址并不需要双引号("")
Sub 单元格简写()
'[a3].Select ’ 单元格引用
[b2:c6].Select '单元格区域引用
[a3,b2:c6,b8:d12].Select '多区域引用
[a:a].Select '整列引用
[1:1].Select '整行引用
End Sub
'单元格简写的也支持引用子集
Sub 子集引用()
[b2:c6].Item(3).Select '区域1中的第3个单元格，从左到右，从上到下
Range(“b2:c6”)(3).Select '区域1中的第3个单元格，从左到右，从上到下
[b2:c6].Cells(4).Select '区域1中的第4个单元格
End Sub
Sub 动态区域的引用()
a = Application.CountA([a:a]) '赋值a=a列非空单元格的数目
b = Application.CountA([1:1]) '赋值b第一行非空单元格的数目
Range(Range(“a1”), Range(Chr(64 + b) & a)).Select '利用chr函数，让字母形式的列号也支持变量
End Sub
Sub chr函数字符循环()
For i = 1 To 655 'for循环，从1到655
Cells(i, 1) = i '单元格填充数字为i
Cells(i, 2) = Chr(i) '单元格填充chr函数
Next '继续向上for循环
End Sub
Sub range引用区域且有变量()
Dim i
i = 1
Range(“a1:c” & i).Select '引用单元格是区域且有变量
Cells(i, “c”).Select '引用的是单个单元格且有变量
[a1:19].Select '引用的是区域或单元格且无变量
End Sub
'行列引用
Sub 列引用()
Columns(1).Select '选中第一列
Columns(“b”).Select '选中第2列
Columns(“c:e”).Select '选中c-e列
End Sub
Sub 行引用()
Rows(1).Select '选中第一行
Rows(“2”).Select '选中第二行
Rows(“3:4”).Select '选中第三，四行
End Sub
Sub range行列表式法()
Range(“1:1”).Select '选中第1行
Range(“2:4”).Select '选中第2到4行
Range(“a:a”).Select '选中A列
Range(“b:d”).Select '选中b到d列
End Sub
Sub 简写法()
[a:a].Select '选中A列
[b:d].Select '选中B到D列
[1:1].Select '选中第一行
[2:4].Select '选中2到4行
End Sub
Sub 全选()
Rows.Select '选择所有行
Columns.Select '选择所有列
Cells.Select '选择所单元格
i = Rows.Count 'i=所有行数
j = Columns.Count 'j=所有列数
k = Cells.Count 'k=所有单元格数
End Sub
Sub 动态引用使用区域()
a = Application.CountA(Columns(1)) '赋值a=a列非空单元格的数目
b = Application.CountA(Rows(1)) '赋值b第一行非空单元格的数目
Range(“a1”, Cells(a, b)).Select '选中所有非空单元格
End Sub
'-------------------------------------------------
'Range.Row 属性
'返回区域中第一个子区域的第一行的行号
'Range.Column 属性
'返回指定区域中第一块中的第一列的列号
'-------------------------------------------------
Sub test44()
i = Range(“a3:b9”).Range(“a5”).Row '在区域1中的A5单元格在整个表中的行号
j = Range(“a3:b9”).Row 'a3单元格的行号
i = Range(“b3:d9”).Range(“a5”).Column '区域1中的A5单元格在整个表中的列号
j = Range(“b3:d9”).Column 'b3单元格的列号
End Sub
Sub row应用()
For Each rw In Rows(“1:13”) 'for循环，在1到13行的每一,行里
If rw.Row Mod 2 = 0 Then '如果行号÷2=0，然后
rw.RowHeight = 15 '调整行高为5
End If '结束if函数
Next rw '循环
End Sub
'单元格的值表示方法
Sub 单元格值表示()
a = [a1].Value '实际是什么，就是什么
b = [a1].Text '看到是什么，就是什么
c = [a1] '实际是什么就是什么
End Sub
'注意：一个单元格可以省略value，多单元格区域不能省略
Sub 多区域赋值()
Range(“e1:e4”) = Range(“d1:d4”).Value
End Sub
'单元格地址与引用
Sub 地址与引用()
Set rng = [b2:f2]
[a9] = rng.Address(1, 1) '绝对引用
[b9] = rng.Address(0, 0) '相对引用
[c9] = rng.Address(1, 0) '混合引用
[d9] = rng.Address(0, 1) '混合引用
End Sub
'总结：1代表固定，0代表不固定,默认是绝对引用
Sub 地址引用实例()
'将表三成绩中为空的单元格标为未考
Dim rng As Range, rn$
On Error Resume Next '当出错时跳转下一步
For Each rng In Sheet3.Range(“b2:d10”) '在表3里的单元格区域1的每一个单元格
If rng = “” Then rn = rn & rng.Address & “,” '如果单元格为空，然后rn的值=rn＋rng单元格+，
Next '循环
Range(Left(rn, Len(rn) - 1)) = “未考” '单元格填充“未考"
End Sub
'------------------------------------------------------------
'1.Range.Cut 方法
'将单元格区域剪切到指定的区域
'2.Range.Copy 方法
'将单元格区域复制到指定的区域
'------------------------------------------------------------
Sub 移动复制()
Range(“a1:d8”).Cut Range(“f1”) '剪切区域一，并粘贴在f1处
Range(“f1:i8”).Copy Range(“a1”) '复制区域一，并粘贴在A1处
End Sub
Sub 另类复制方法()
Range(“a10:d17”) = Range(“a1:d8”).Value '直接相等复制法（需要选择两个区域，较麻烦），区域一等于区域2的值
End Sub
'注：
'1.等号后的区域一定要加value.否则不成功
'2.被赋值的区域格式全部去掉
Sub 出差登记表记录保存()
Dim rs%, crs%
rs = Application.CountA([d:d]) '赋值rs等于d列的非空单元格数量
crs = Application.CountA(Sheets(“出差记录表”).[a:a]) + 1 '赋值crs等于表1中a列的
1
If rs = 1 Then GoTo 100 '如果rs等于1然后跳转100步
Range(“a2:d” & rs).Copy Sheets(“出差记录表”).Range(“a” & crs) '复制区域1，粘贴在表1中单元格1中
End
100: '第100行
MsgBox “没有要保存的数据！” '弹窗提醒
End Sub
'工作表中单元格，行与列的插入与删除
Sub 插入()
Rows(2).Insert '在第二行之前插入一行
End Sub
Sub 隔行插入()
Dim r%
Do 'do循环
r = r + 2 '赋值r
Rows®.Insert '在第r行插入一行
Loop Until Cells(r + 1, 1) = “” '直到单元格1为空时停止循环
End Sub
Sub 删除()
Rows(1).Delete '删除第一行
End Sub
Sub 隔行删除()
Dim r, s
m = Application.CountA(Columns(1)) '赋值m等于第一列的非空单元格的数量
For r = 1 To m / 2 'for循环
Rows®.Delete '删除第r行
Next '循环
End Sub
'活动单元格：activecell,工作表中活动单元格只有一个
Sub activecells()
a = ActiveCell.Address '取得活动单元格地址
Cells(2, 3).Activate '激活指定单元格
End Sub
'selection光标所选区域
Sub 光标所选区域()
Selection = 1 '鼠标选中的单元格填充1
End Sub
Sub 在selection中的改变活单元格()
For i = 1 To Selection.Count 'for循环从1到鼠标选中的单元格数量
Selection(i).ClearContents '清除选中区域的第i个单元格
Next '循环
End Sub
Sub 运用11()
Dim i As Range
For Each i In Selection 'for循环，在选中区域的每一个单元格
If i = “” Or i = “缺勤” Then '如果i为空值，或i为缺勤
i = “×” '单元格i等于×
End 'If结束if语句
Next i 'for循环
End Sub
'小结：selection的好处在于，可以很自由灵活选择你想要处理的单元格区域
Sub 宏3()
Range(“C4”).Select '单元格c4选中
Selection.CurrentRegion.Select '返回单元格C4所在的区域并选中
End Sub
Sub 宏4()
Range(“G6”).Select '选中G6单元格
End Sub
'Range.CurrentRegion 属性
'返回一个 Range 对象，该对象表示当前区域。
Sub 当前区域()
[a1].CurrentRegion.Select '选中单元格A1所在的区域
[f8].CurrentRegion.Select '选中单元格f8所在的区域
End Sub
Sub currentregion应用()
Rows(8).Clear '清除第8行的数据（包括格式）
a = [b2].CurrentRegion.Address '返回单元格B2所在单元格的区域地址
b = [b5].CurrentRegion.Address '返回单元格B5所在单元格的区域地址
c = [b2].CurrentRegion.Count + 1 '返回单元格B2所在单元格的区域地址+1
Set c = Range(“b8”, Cells(8, c)) '设置c为单元格区域1
c.FormulaArray = “=” & a & “+” & b '单元格区域c中输入数组公式
End Sub
'usedrange与currentregion
'如果表中只有一个区域，两者最后的结果是一样的
'只是表达方式不一样
Sub u与c()
UsedRange.Select '选中表中已使用的单元格区域，包括两个区域中间的空白部分
Range(“A1”).CurrentRegion.Select '选中A1所在的单元格区域
End Sub
'Range.Offset 属性
'返回 Range 对象，它代表位于指定单元格区域的一定的偏移量位置上的区域。
'表达式.Offset(偏移行, 偏移列)
'表达式 一个代表 Range 对象的变量。
'偏移行列的数字可以是：正数，负数，零值
Sub test32()
[a1].Offset(1, 2).Select '选中单元格A1行偏移1，列偏移2
[a1].Offset(2).Select '选中单元格A1行偏移2，列不偏移
[a1].Offset(, 2).Select '选中单元格A1行不偏移，列偏移2
'如果offset前面的range对象是一个区域，则偏移后也结果尺寸不变
[a1:d1].Offset(1, 2).Select '选中区域1行偏移1，列偏移2
[a1:d1].Offset(2).Select '选中区域1行偏移2，列不偏移
[a1:d1].Offset(, 2).Select '选中区域1行不偏移，列偏移2
End Sub
Sub offset应用1()
Dim i%
For i = 2 To 8 Step 2 'for循环从2到8,步进值为2
[a1:e1].Copy [a1:e1].Offset(i) '复制单元格区域1，到区域2偏移i行的位置
Next i '循环
End Sub
Sub offset应用2()
Dim i%
For i = 2 To 8 Step 2 'for循环从2到8
[a1:e1].Offset(i) = “” '单元格区域1行偏移i行填充空
Next i '循环
End Sub
'Range.Resize 属性
'调整指定区域的大小。返回 Range 对象，该对象代表调整后的区域。
'语法
'表达式.Resize(行数, 列数)
'表达式 一个返回 Range 对象的表达式。
Sub test447()
[d1].Resize(2, 3).Select '选中d1单元格为左上角，扩充2行，3列的单元格区域
[d1].Resize(2).Select '选中D1单元格为左上角，扩充两行的单元格区域
[d1].Resize(, 3).Select '选中D1单元格为左上角，扩充3列的单元格区域
End Sub
Sub 保存()
Dim i%, j%, k%
i = [a1].CurrentRegion.Rows.Count - 1 '赋值i等于A1单元格所在的区域的行数-1
j = [a1].CurrentRegion.Columns.Count '赋值j等于A1单元格所在的区域的列数
k = Application.CountA(Sheet2.Columns(1)) '赋值k等于表2中第一列的非空单元格的数量
[a2].Resize(i, j).Copy Sheet2.[a1].Offset(k) '复制单元格A2为左上角，扩充i行，j列的单元格区域，粘贴到表2中A1单元格偏移k行后的位置
End Sub
'Range.EntireRow 属性
'返回一个 Range 对象，该对象表示包含指定区域的整行（或多行）。
'语法
'表达式.EntireRow
'表达式 一个代表 Range 对象的变量。
'Range.EntireColumn 属性
'返回一个 Range 对象，该对象表示包含指定区域的整列（或多列）
'语法
'表达式.EntireColumn
'表达式 一个代表 Range 对象的变量。
Sub test1233()
[a1].EntireRow.Select '选中单元格A1所在的行
[a1].EntireColumn.Select '选中单元格A1所在的列
[a1:a4].EntireRow.Select '选中区域1所在的所有行
[a1:d1].EntireColumn.Select '选中区域1所在的所有列
End Sub
Sub test1()
Dim rng As Range, ads As String
For Each rng In [a1:a10] 'for循环，在区域1中的每一个单元格
If rng = “” Then ad = ad & rng.Address & “,” '如果单元格为空，然后赋值ad等于ad+单元格地址+，
Next '循环
ads = Left(ad, Len(ad) - 1) '赋值ADS等于提取去掉ad最后一个字符的值
Range(ads).EntireRow.Delete '删除ads单元格所在的行
End Sub
'Range.SpecialCells 方法
'返回一个 Range 对象，该对象代表与指定类型和值匹配的所有单元格。
'语法
'表达式.SpecialCells(Type, Value)
'表达式 一个代表 Range 对象的变量。
Sub 批注汇总()
MsgBox Application.Sum(Selection.SpecialCells(-4144)) '对所有鼠标框选的含有注释的单元格进行求和并弹窗提示
End Sub
Sub 删除空行()
On Error GoTo 100 '如果出错跳转100行
Selection.SpecialCells(xlCellTypeBlanks).Select '选中鼠标框选的所有空白单元格选中
Selection.EntireRow.Delete '将选中的所有单元格所在的行删除
Exit Sub '退出程序
100: '100行
MsgBox “没有空行” '弹窗提醒
End Sub
'Range.Find 方法
'在区域中查找特定信息
'语法
'表达式.Find(What, After, LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)
'表达式 一个代表 Range 对象的变量。
Sub 查找最后一个单元格()
Set endrng = Cells.Find("", , xlFormulas, , , xlPrevious) '赋值endrng的值等于查找，从后往前查找
Range([a1], endrng).Select '选中A1单元格和最后一个单元格吗，即所有非空非空单元格区域
End Sub
'
Sub 查询系统()
ends = Columns(1).Find(“*”, , , , , searchdirection:=xlPrevious).Row '动态找到A列的最后一个单元格
Range(“g3:l999”).Clear '清除单元格区域
For Each rng In Range(“a2:a” & ends) 'for循环，在单元格区域中的每一个单元格
m = m + 1
If rng Like Range(“h1”) Then 'rng单元格值与H1单元格值相等，那么
k = k + 1
Range(“a” & m + 1 & “:e” & m + 1).Copy Range(“g” & k + 2) '将记录复制到另一个区域
End If
Next
End Sub
Sub 开单()
Set es = Cells.Find(“*”, , xlFormulas, , , xlPrevious) '查找最后一个非空单元格
a = es.Address '返回最后一个非空单元格的地址
[b2] = “SM” & Format(Now(), “ymdhms”) '赋值B2单元格值等于SM+当前日期
Range([a5], es.Offset(4)) = “” '赋值单元格区域为空
[e2] = “” '将e2清空
End Sub
Sub 保存444()
On Error GoTo 100 '如果出错跳转100
Dim es As Range, a%
If Sheet2.[f:f].Find([b2]) = [b2] Then '如果表2中f行存在B2的值
MsgBox “已经保存过了!” '提示已经保存过了
Else '否则
4.166666667
Set es = Cells.Find(“*”, , xlFormulas, , , xlPrevious) '赋值es为非空单元格的最后一个单元格
a = Application.CountA(Sheet2.[a:a]) '赋值a等于表2中a列的非空单元格个数
If es.Row = 4 Then MsgBox “没有填写内容”: End '如果es单元格所在的行数为4，就弹窗
Range([a5], es).Copy Sheet2.Cells(a + 1, 1) '复制单元格区域1，在表2中的单元格1中粘贴
Sheet2.Cells(a + 1, “f”).Resize(es.Row - 4) = [b2] '保存入库单，单元格1行扩充es，列扩充row-4，填充B2
Sheet2.Cells(a + 1, “g”).Resize(es.Row - 4) = [e2] '保存供应商，单元格2行扩充es，列扩充row-4，填充e2
Sheet2.Cells(a + 1, “h”).Resize(es.Row - 4) = Now() '保存日期时间，单元格3扩充es，列扩充row-4，填充当前时间
MsgBox “保存成功!” '弹窗
End If '结束if语句
End Sub
Sub 计算()
Set es = Columns(3).Find(“*”, , xlFormulas, , , xlPrevious) '赋值es等于第3列中最后一个非空单元格值
For Each rng In Range([c5], es) 'for循环，在单元格区域1中的每一个单元格
rng.Offset(0, 2) = rng.Offset(0, 1) * rng '单元格行偏移0，列偏移2，填充rng单元格行偏移0，列偏移1+rng值
Next '循环
End Sub
'1.从录制一个宏开始。操作：(ctrl+向上键、ctrl+向下键、ctrl+向左键、ctrl+向右键)
'2.看代码
Sub 宏5()
Selection.End(xlDown).Select
Selection.End(xlToRight).Select
Selection.End(xlUp).Select
Selection.End(FxlToLeft).Select
End Sub
'Range.End 属性
'返回一个 Range 对象，该对象代表包含源区域的区域尾端的单元格。
'等同于按键 (End+向上键、End+向下键、End+向左键、End+向右键)
'语法
'表达式.End (Direction)
'表达式 一个代表 Range 对象的变量。
'方向 写法 值
'向上 xlUp - 4162
'向下 xlDown - 4121
'向左 xlToLeft - 4159
'向右 xlToRight - 4161
'========================================================================================
Sub test151()
i = Cells(Rows.Count, 3).End(xlUp).Row '返回工作表最后一行，第三列的单元格，向上ctrl+向上键的单元格的行数
j = Cells(Rows.Count, 3).End(xlUp).Address '返回工作表最后一行，第三列的单元格，向上+向上键的单元格的地址
Range(“a1”, j).Select '选中单元格1
Range(“a1”, Cells(i, 3)).Select '选中区域1
End Sub
Sub 分期付款最后月()
i = Cells(Rows.Count, 1).End(xlUp).Row '找到A列的最后一行，并向上CTRL+向上键，找到非空单元格的最后一个，返回行号
Range(“n2”, Cells(i, “n”)) = “” '将单元格区域1清空
For j = 2 To i 'for循环，从2到i
k = Cells(j, “n”).End(xlToLeft).Column '赋值k等于单元格nj向左按ctrl+向左键得到的单元格
Cells(j, “n”) = Cells(1, k) '赋值单元格nj等于单元格k1的值
Next j '循环
End Sub
'这里讨论怎样找到最后一个单元格！
'不考虑最后量个单元格是：是公式，错误值，隐藏之类的特殊情况。
'以最后是一个常规的值为准。且以A列的最后一个单元格为准
'---------------------------------------------------------------
Sub 最后的单元格()
a = Cells(Rows.Count, 1).End(xlUp).Row 'end属性
b = Columns(1).Find(“*”, , , , , xlPrevious).Row 'find方法
c = Cells.SpecialCells(xlCellTypeLastCell).Row 'specialcells方法
d = Sheet1.UsedRange.Rows.Count 'usedrange属性
e = [a1].CurrentRegion.Rows.Count 'currentregion属性
f = WorksheetFunction.CountA([a:a]) '工作表函数counta
g = Application.CountIf([a:a], “<>”) '工作表函数countif
End Sub
'Application.Union 方法
'返回两个或多个区域的合并区域
'
Sub testkg()
Range(“a1:b3,c5:d8”).Select 'range表达式，选中两个不相邻的单元格区域
Union([a1:b3], [c5:d8]).Select '单元格区域引用方式，选中两个不相邻的单元格区域
End Sub
'小结：虽然range也可以完成多区域的引用
'但文本地址的引用方式最多不能超过256个字符
'而union却没有这个限制
'我们经常利用变量与union进行单元格的连接
Sub 连接符单元格连接()
Dim rng As Range
For Each rngs In [b2:b10] '在单元格区域1中的每一个单元格
adss = rngs.Address '赋值adss等于单元格的地址
ads = ads & rngs.Address & “,” '赋值ads等于ads+单元格地址+，
Next '循环
ad = Left(ads, Len(ads) - 1) '赋值ad等于ads去掉最后一位数，即去掉，
End Sub
Sub union单元格连接()
Dim rng As Range, rngs As Range
Set rng = [b2] '赋值rng等于B2单元格
For Each rngs In [b2:b10] '在单元格区域1中的每一个单元格
adss = rngs.Address '赋值adss等于单元格地址
Set rng = Union(rng, rngs) '赋值rng等于两个单元格地址
ads = rng.Address '赋值ads等于rng的地址
Next '循环
End Sub
Sub 条件筛选()
For Each rnge In Range([b2], Cells(Application.CountA([a:a]), 2)) '在单元格区域中的每一个单元格
If rnge > 90 Then '如果rng大于90，然后
k = k + 1
If k = 1 Then '如果k=1，然后
Set rn = rnge '赋值rn=rnge
Else '否则
Set rn = Union(rn, rnge) '赋值rn=单元格区域
aaa = rn.Address '赋值aaa=rn的单元格地址
End If '结束if语句
End If '结束if语句
Next '循环
For Each rngs In rn '在rn中的每一个单元格
n = n + 1
Cells(n + 1, “d”) = Cells(rngs.Row, “a”) '单元格1等于单元格2
Cells(n + 1, “e”) = rngs '单元格2等于单元格3
Next
End Sub
'Application.Intersect 方法
'返回一个 Range 对象，该对象表示两个或多个区域重叠的矩形区域。
Sub test得分()
If Intersect([a1:d10], Selection) Is Nothing Then '注释：Is Nothing 用于判断对象是否存在，对象可以是工作簿，工作表，单元格区域等
MsgBox “没有交集” '弹窗
Else
MsgBox Intersect([a1:d10], Selection).Address '弹窗两个区域交集的地址
Intersect([a1:d10], Selection).Select '选中两个区域交集的区域
End If
End Sub
Sub 隔行插入fds()
For i = 0 To Application.CountA(Columns(1)) * 2 Step 2 'for循环从0到第一列的非空单元格数*2，步进值为2
Cells(i, 1).EntireRow.Insert 'd单元格Ai所在的行插入一行
’ Intersect([a1:d2].Offset(i), [a2:d3].Offset(i)).EntireRow.Insert '单元格区域1偏移i行，单元格区域2偏移i行，两个区域的交集所在的整行，插入一行
Next
End Sub
'Range.NumberFormatLocal 属性
Sub 获取单元格设置数字格式()
For Each rng In [a1:a3]
Cells(rng.Row, 2) = rng.NumberFormatLocal '获取单元格的格式代码
Next rng
End Sub
Sub 给单元格设置数字格式()
For Each rng In [a1:a3]
rng.NumberFormatLocal = “0.00”
Next rng
End Sub
Sub 保存1111()
Set es = Cells.Find(“*”, , xlFormulas, , , xlPrevious)
a = Application.CountA(Worksheets(“记录保存”).[a:a])
Range([a5], es).Copy Worksheets(“记录保存”).Cells(a + 1, 1)
With Worksheets(“记录保存”)
.Cells(a + 1, “f”).Resize(es.Row - 4) = [b2] '保存入库单
.Cells(a + 1, “g”).Resize(es.Row - 4) = [e2] '保存供应商
.Cells(a + 1, “h”).Resize(es.Row - 4) = Now() '保存日期时间
.Cells(a + 1, “h”).Resize(es.Row - 4).NumberFormatLocal = “e-m-d aaaa”
End With
MsgBox “保存成功!”
End Sub
'Font 对象
'包含对象的字体属性（字体名称、字号、颜色等等）。
'Range.ClearFormats 方法
'清除对象的格式设置
'常见font对象的属性
Sub font对象属性()
With [a2:a6].Font 'with 赋值，用.代替单元格格式
.Name = “微软雅黑” '字体设置为微软雅黑
.Size = 8 '字号
.Bold = True '加粗
.Color = RGB(255, 0, 255) '颜色
End With
End Sub
Sub 大于90分的颜色设置为红色()
Set i = Cells(Rows.Count, 3).End(xlUp) '赋值i=第3列的非空单元格值的最后一个
Range([b2], i).ClearFormats '清空单元格区域
For Each rng In Range([b2], i)
If rng.Value >= [f1] Then
With rng.Font
.Name = “华文琥珀”
.Size = 20
.Bold = True
.Color = RGB(255, 0, 0)
End With
End If
Next rng
End Sub
'Interior 对象
'代表一个对象的内部
'针对interior对象，我们用得最多的是它的颜色，下面就来讨论一下。
Sub 索引颜色值()
For i = 1 To 56 'for循环从1到56
Cells(i, 1).Interior.ColorIndex = i '单元格的底纹颜色为i
Cells(i, 2) = i '单元格的值为i
Next i '循环
End Sub
Sub 早期颜色值()
For i = 0 To 15 'for循环从0到15
Cells(i + 1, 1).Interior.Color = QBColor(i) '单元格的底纹颜色为
Cells(i + 1, 2) = i
Next i
End Sub
Sub 三原色颜色值()
Cells(2, 4).Interior.Color = RGB(100, 100, 100)
End Sub
Sub 直接颜色值() '此颜色有255^3种颜色
Cells(1, 1).Interior.Color = [b1] '单元格a1的底纹颜色值为B1单元格的值
End Sub
Sub 格式化工资条()
Dim i%
i = Cells(Rows.Count, 1).End(xlUp).Row '赋值i等于非空单元格的最后一个
For j = 1 To i 'for循环从1到i
If j Mod 2 Then '如果j能被2整除
With Cells(j, 1).EntireRow.Range(“a1:g1”).Font '单元格1所在的整行中的A1:G1的格式
.Bold = True '加粗
.Size = 8 '大小为8
.ColorIndex = 56 '字体颜色为56号
End With
Else
With Cells(j, 1).EntireRow.Range(“a1:g1”).Interior '单元格1的所在的整行中的A1：G1的的低温
.ColorIndex = 40 '底纹颜色为40
End With
End If
Next j
End Sub
Sub 清除格式化()
Selection.ClearFormats '选中项清除格式
End Sub
Sub 根据查找功能拾取的颜色求平均()
On Error GoTo 100 '如果出错跳转100行
Dim erng As Range, rng As Range, i As Long
i = Application.FindFormat.Interior.Color
Set erng = Cells(Rows.Count, “e”).End(xlUp)
For Each rng In Range([b2], erng)
If rng.Interior.Color = i Then k = k + rng.Value: n = n + 1
Next
MsgBox “最后平均分为：” & k / n & “分”
End
4.166666667
MsgBox “查找功能没有拾取到颜色！”
End Sub
Option Explicit
'Worksheet.Paste 方法
'将“剪贴板”中的内容粘贴到工作表上。
'表达式.Paste(Destination, Link)
'表达式 一个代表 Worksheet 对象的变量。
Sub 粘贴()
'Range(“B1:B6”).Copy Range(“c9”) '将单元格区域1复制，在C9单元格上粘贴
Range(“B1:B6”).Copy '复制区域无公式
Sheet1.Paste [a15] '粘贴到A15单元格
End Sub
Option Explicit
'Range.PasteSpecial 方法
'将 Range 从剪贴板粘贴到指定的区域中。
'语法
'表达式.PasteSpecial(Paste, Operation, SkipBlanks, Transpose)
'表达式 一个代表 Range 对象的变量。
Sub 选择怪粘贴()
Range(“c2:c10”).Copy '复制单元格区域1
Range(“d2”).PasteSpecial 12 '粘贴在D2处，并粘贴为值和数字格式
End Sub
Sub 选择性粘贴运算()
Range(“b2:b9”).Copy '复制单元格区域1
Range(“d2”).PasteSpecial , 2 '粘贴在D2处，粘贴的数据与原来D2数据相加
Range(“c2:c9”).Copy '复制单元格区域1
Range(“d2”).PasteSpecial , 2 '粘贴在D2处，粘贴的数据与原来D2数据相加
End Sub
Sub 选择怪粘贴跳过空单元()
Range(“b2:b9”).Copy '复制单元格区域1
Range(“e2”).PasteSpecial , , True '粘贴在e2单元格，并且跳过空单元格
End Sub
Sub 选择性粘贴转置()
Range(“a2:b9”).Copy '赋值单元格区域1
Range(“a11”).PasteSpecial 12, , , True '粘贴在a11单元格，粘贴为值和数字格式，并且转置
End Sub
Option Explicit
'Range.Merge 方法
'由指定的 Range 对象创建合并单元格。
Sub 合并单元格()
Application.DisplayAlerts = False '关闭弹窗提示
Selection.Merge '合并选中的单元格
Application.DisplayAlerts = True '打开弹窗提示
End Sub
Sub 合并单元格实例()
Dim er%, rng%, rg As Range
Application.DisplayAlerts = False '关闭弹窗提示
er = Application.CountA([a:a]) '赋值er=a列非空单元格的数量
For rng = er To 2 Step -1 'for循环，从er到2，步进值为-1
Set rg = Range(“a” & rng) '赋值rg=单元格值
If rg = rg.Offset(-1) Then rg.Offset(-1).Resize(2).Merge '如果单元格1等于单元格1向上偏移1行的单元格，然后，单元格1上一个单元格扩充两行，丙合并区域
Next '循环
Application.DisplayAlerts = True '打开弹窗提示
End Sub
'-----------------------------------------------------------------------
'Range.MergeArea 属性
'返回一个 Range 对象，该对象代表包含指定单元格的合并区域。
'Range.UnMerge 方法
'将合并区域分解为独立的单元格
'--------------------------------------------------------------------------
Sub test1581()
a = Range(“a2”).MergeArea.Count '统计单元格中合并单元格的数量
Range(“a2”).UnMerge '分解合并单元格
End Sub
Sub 解除合并单元格后保持原来的数据()
Dim b%, rng As Range
For Each rng In Selection '在选中的区域中的每一个单元格
b = rng.MergeArea.Count '赋值b=单元格的合并单元格数量
rng.UnMerge '分解合并的单元格
rng.Resize(b) = rng '单元格扩充b行，并且等于rng的值
Next '循环
End Sub
'Comment 对象
'代表单元格批注
'批注添加
Sub 批注添加()
With Range(“A1”) 'with语句
If .Comment Is Nothing Then '如果A1没有批注
.AddComment.Text “123” '新加批注123
.Comment.Visible = False '批注显示模式设置为不可见
End If '结束if语句
End With '结束with语句
End Sub
Sub 删除批注()
Dim rng As Range
For Each rng In Selection '在选中的区域中的每一个单元格
If Not rng.Comment Is Nothing Then '如果单元格批注是存在的
rng.ClearComments '清除单元格批注
End If '结束if语句
Next
End Sub
Sub 批量添加批注()
For Each rng In Range(“a2:a20”) '在单元格区域中的每一个单元格
rng.ClearComments '清除批注
If rng >= 90 Then rng.AddComment.Text “优秀” '如果单元格>=90，然后添加批注“优秀”
Next '循环
End Sub
'修改批注
Sub 修改批注()
With Range(“a2”)
.ClearComments
.AddComment.Text “111” '添加批注
.Comment.Shape.Height = 50 '设置批注高度
.Comment.Shape.Width = 40 '设置批注宽度
.Comment.Shape.Fill.UserPicture “C:\Users\Administrator\Desktop\VBA素材\第3章 单元格区域操作\7pic\阿汤.png”
End With
End Sub
Sub 批量将批注增加背景()
For Each rng In Selection '在选中的每一项
paths = “C:\Users\Administrator\Desktop\VBA素材\第3章 单元格区域操作\7pic” & rng.Value & “.png” '赋值paths=图片地址
rng.ClearComments '清除批注
rng.AddComment '添加批注
rng.Comment.Shape.Height = 50 '设置批注高度
rng.Comment.Shape.Width = 40 '设置批注宽度
rng.Comment.Shape.Fill.UserPicture paths '批注背景填充图片
Next '循环
End Sub
'Shapes 对象
'指定的工作表上的所有 Shape 对象的集合。
'说明
'每个 Shape 对象都代表绘图层中的一个对象，如自选图形、任意多边形、图片、图表等。
Sub abc()
Dim ob As Shape '申明变量ob为图形
n = Sheet1.Shapes.Count '赋值表1中的图形数量
For Each ob In Sheet1.Shapes '在表1中的每一个图形
k = k + 1
ob.Select '选中图形ob
Cells(k + 1, “f”) = ob.Name '图形名称
Cells(k + 1, “g”) = ob.Type '图形类型
Cells(k + 1, “h”) = ob.Top '顶端坐标
Cells(k + 1, “i”) = ob.Left '左端坐标
Cells(k + 1, “j”) = ob.Width '宽度
Cells(k + 1, “k”) = ob.Height '高度
Next ob
End Sub
Sub 图形插入()
Sheet3.Shapes.AddPicture ThisWorkbook.Path & “\7pic\林志玲.png”, _
True, True, 100, 100, 70, 70 '在表3中插入图片
End Sub
Sub 图形删除()
For Each shp In Sheet3.Shapes '在表3中的每一个图形
shp.Delete '删除图形
Next shp '循环
End Sub
Sub 宏1545()
For Each shap In Sheet1.Shapes '在表1所有图形中的每一个
If shap.Type <> 8 Then shap.Delete '如果图形的类型不等于8，然后删除图形
Next shap '循环
For Each rng In Range([a2], Cells(Application.CountA(Columns(1)), 1)) '在第一列除了A12以外的非空单元格
i = ThisWorkbook.Path & “\7pic” & rng & “.png” '赋值i=图片地址
Set rngs = Cells(rng.Row, 2) '赋值rngs=单元格
Sheet1.Shapes.AddPicture i, True, True, rngs.Left, rngs.Top, rngs.Width, rngs.Height '单元格填充图片
Next rng '循环
End Sub
Sub 多表合并()
Dim i%, rs%, rss%, st As Worksheet, zst As Worksheet
Set zst = Sheets(“1季度”) '将汇总工作表"1季度"定义为变量zst
For i = 1 To 3
Set st = Sheets(i & “月”) '将1-3每月的工作表定义为变量st
rs = st.UsedRange.Rows.Count ’ 计算1-3月份每个表的最后一行
rss = zst.UsedRange.Rows.Count + 1 '计算“1季度的最后一行的下一行”
st.Range(“a2:b” & rs).Copy zst.Cells(rss, 1) '复制1-3表的数据到总表中
zst.Cells(rss, 3).Resize(rs - 1) = i & “月” '将1-3表的工作表名写入到总表对应的记录中
Next
End Sub
Sub 多表拆分()
For f = 1 To 3 '循环三次（只拆分三个月）
Worksheets.Add.Name = f & “月” '新建工作表，并以月份命名
For Each rng In Sheets(“总表”).Range(“a2:a15”)
If rng.Value = f & “月” Then '如果a列的值等于当前的月份
n = “a” & rng.Row & “:d” & rng.Row '构造被复制的源表区域
Y = Y + 1 '新表行数累计
If Y = 1 Then
Sheets(“总表”).Range(“a1:d1”).Copy Sheets(f & “月”).Cells(Y, 1)
End If
Sheets(“总表”).Range(n).Copy Sheets(f & “月”).Cells(Y + 1, 1) '则将当前月份所在行复制到新建月份表中
End If
Next
Y = 0 '分表行数累计归零
Next
End Sub
' 1.数组概念
' 数组就是一个列表或者一组数据表.
'
' 2.数组位置
' 数组存储在内存中.
'
' 3.数组特点
' a.读写速度快（从内存读取数据要比从硬盘读取快）
' b.无法永远保存(内存只是暂存空间)
' 4.数组分类
' a.一般分为：常量数组，静态数组，动态数组
' b.如按维度为：1维，2维，3维......60 维
'
' 5.当我们学会了数组，会发现以前的写的很多代码可以从数组的角度重写
'
Sub test25858()
Dim arr1(3)
Dim arr2(1 To 3)
Dim arr3(1 To 3, 1 To 2)
Dim arr4(3, 2)
End Sub
' 数组最多有60维，但在excel中一般最到2维
' 1.excel中的一行或一列可以转换1维数组
' 2.excel中的多行多列可以转换成2维数组
'
Sub test314()
arr1 = [{“A”,“B”,“C”,“D”}]
arr2 = Application.Transpose([{1;2;3;4}]) '转置数组，转换为行数组，赋给数组2
End Sub
Sub test322()
arr3 = [{“张”,1;“王”,2;“陈”,3;“李”,4;“林”,5}] '将行数组赋给数组3
End Sub
Sub test4()
arr = Array(1, 2, 3, 4) '将行数组赋给数组
arr1 = Array(Array(“a”, “b”), Array(1, 2, 3)) '将两个行数组赋给数组1，组成一个两行，三列的数组
End Sub
Sub 向数组中指定的位置写入数据()
Dim arr(1 To 9) '新创建一个9行数组
arr(3) = “我” '赋予第三行数据“我”
arr(5) = “是” '赋予第五行数据"是"
arr(7) = “谁” '赋予第七行数据"谁"
End Sub
Sub 循环向数组中写入数据()
Dim arr(1 To 4) '新创建一个4行数组
For Each rng In [a1:a4] '在数组1中的每一个单元格
n = n + 1
arr(n) = rng '将单元格的值赋予数组的第n行
Next
End Sub
Sub 常量数组数据写入一般数组()
Dim arr() '创建一个数组（未确定维度）
arr = Array(“V”, “B”, “A”, 9) '赋值数组四行并填充数据
End Sub
Sub 单元格区域数据批量写入数组()
arr = Application.Transpose([a1:a4])
arr2 = Application.Transpose([a7:d7])
arr1 = Application.Transpose(Application.Transpose([a7:d7]))
End Sub
'怎样在数组中取数
Sub 取数组中指定位置的元素()
arr1 = [a2:a5]
MsgBox arr1(2, 1)
MsgBox arr1(4, 1)
End Sub
Sub 方法1循环取数()
arr = [a2:a9]
[b1] = arr(2, 1)
For i = 1 To 8
Cells(i, 3) = arr(i, 1)
Next
End Sub
Sub 方法2一次性取数()
arr = [a2:a5]
Range(“d1:d” & 4) = arr
End Sub
Sub 用transpose函数转置()
arr = [a2:a5]
arr1 = Application.Transpose(arr)
[a7:d7] = arr1
[a8:c8] = arr1
[a9:e9] = arr1
'注意左右两边尺寸的对应
End Sub
Sub shell函数的用法()
Shell “C:\Program Files\AutoCAD 2010\acad.exe”, 1 '给出路径直接执行exe程序,并显示在界面
Shell “explorer.exe C:\Users\Administrator\Desktop\通知.docx”, 1 'windows程序直接输入程序名执行
Shell " control.exe" '打开控制面板
'shell功能本身并不强大，主要是它可以调用许多指令，如CMD，rundll32等等
Shell cmd '打开cmd命令
Shell “cmd.exe /c copy c:/1.txt d:” '将盘中的1.txt复制到d盘中 /c代表执行指定命令后中断
Shell “cmd.exe /c del c:\1.txt” '删除c盘中的1.txt文件
End Sub
Sub test6()
Sub 字典写入()
Set d = CreateObject("scripting.dictionary")
d(1) = 2
d(2) = 3
'等同于
d.Add 1, 2
d.Add 2, 3
End Sub
'Dim d As New Dictionary '定义一个新字典d（可省略）
Set d = CreateObject(“scripting.Dictionary”) '创建一个字典对象
d.Add “张三”, “123” '向字典中写入key “张三”, item “123”
d.Add “李四”, “456” '向字典中写入key “李四”, item “456”
'i = d.Keys(1) '前期绑定写法 '方法1
k = d.keys '方法2 将字典keys赋值到数组k
l = k(1) '方法2 赋值l=数组中的第一个值
j = Application.Index(d.keys, 2) '方法3（直接在keys中取值）赋值l=第一个key值
'Items方法
'返回一个数组，其中包含了一个 Dictionary 对象中的所有项目。
'r = d.Items(1) '前期绑定写法 '方法1
w = d.items '方法2 将字典items赋值到数组w
v = w(1) '方法2 然后在数组w中提取值
s = Application.Index(d.items, 2) '方法2 用工作表函数index在keys中直接取值
t = d(“李四”) '方法3 '利用已知的唯一的key值进行区item的值
'备注：字典key值具有唯一性，可以利用这一特性进行重复项剔除，on error resume next
'Exists方法，如果 Dictionary 对象中存在所指定的关键字则返回 true，否则返回 false。
a = d.Exists(“李四”) '判断字典d里面的key值里面是否有"李四"
'Remove方法，Remove 方法从一个 Dictionary 对象中清除一个关键字，项目对。
d.Remove (“李四”) '将李四从字典中清除,如果李四不存在就会报错
'RemoveAll方法，RemoveAll 方法从一个 Dictionary 对象中清除所有的关键字，项目对。
d.RemoveAll '清除整个字典
End Sub
'总结：
'字典对象的方法有6个：
'Add 添加一条关键字与条目
'Keys 返回所有关键字(形成1维数组)
'Items 返回所有条目(形成1维数组)
'Exists 关键字是否存在(TRUE/FALSE)
'Remove 移除关键字与对应的条目
'RemoveAll 移除所有关键字与对应的条目
'字典对象的属性有4个：CompareMode属性、Count属性、Key属性、Item属性。
Sub testd()
Set d = CreateObject(“scripting.dictionary”)
'1.CompareMode属性
'设置或者返回在 Dictionary 对象中进行字符串关键字比较时所使用的比较模式。
d.CompareMode = 0 '1则不区分大小写，0则区分大小写
d.Add “a”, “”
d.Add “A”, “”
d.Add “张三”, “13434544323”
d.Add “李四”, “13589898999”
d.Add “王五”, “13456565567”
'2.Count属性
'返回一个Dictionary 对象中的项目数.只读属性
k = d.Count '计算d的key数量
'3.Key属性
'在 Dictionary 对象中修改一个 key。
d.Key(“王五”) = “牛三斤” '将key值"王五" 修改为 “牛三斤”
'4.Item属性
'在一个 Dictionary 对象中设置或者返回所指定 key 的 item。对于集合则根据所指定的 key 返回一个 item。读/写。
d.Item(“张三”) = “112233” '将张三对应的item 改为112233
d(“张三”) = 987 '简写 '将张三对应的item改为987
i = d.items '赋值数组i，进行item数值查询
'注意：容易混淆知识点。d.key(“a”)与d(“a”)
End Sub
Sub 错误处理()
On Error Resume Next '出错继续运行，忽略出错警告
i = 1 / 0
On Error GoTo 0 '恢复出错警告
d = 1
j = 2 / 0
End Sub
'字典写入和修改技巧
Sub testdd()
Set d = CreateObject(“scripting.dictionary”) '定义字典d
On Error Resume Next '忽略出错警告
arr = Range(“a2:b” & Cells(Rows.Count, 2).End(xlUp).Row) '将单元格区域赋值到数组里
For i = 1 To UBound(arr) '循环数组
d.Add arr(i, 1), arr(i, 2) '逐个向字典中添加，如果重复忽略掉，只保留第一次的key
Next
i = d.keys
j = d.items
End Sub
'小结：如果有错误后继续执行后的结果是，只记当第1次写入的key与item
'修改（另一种写入方法）技巧
Sub test2d()
Set d = CreateObject(“scripting.dictionary”) '定义字典d
arr = Range(“a2:b” & Cells(Rows.Count, 2).End(xlUp).Row) '赋值数组
For i = 1 To UBound(arr) '循环
j = arr(i, 1)
m = arr(i, 2)
d.Item(arr(i, 1)) = arr(i, 2) '要修改的关键字(key)没有,就增加到字典中
k = d.Item(“张三”)
Next
n = d.items
End Sub
'代码运行总结：
' 对字典Item值的修改：1.有key则修改，无key则添加。
'这两个特点作用非常大，可以求不重复值，可以做分类汇总
'实例一：求每种产品第一次采购价
Sub first()
Dim arr()
On Error Resume Next
Set d = CreateObject(“scripting.dictionary”)
arr = Range(“b1:c” & Cells(Rows.Count, 3).End(xlUp).Row)
For i = 1 To UBound(arr)
d.Add arr(i, 1), arr(i, 2) '只向字典中添加第一条记录
Next
[e1].Resize(d.Count) = Application.Transpose(d.keys)
[f1].Resize(d.Count) = Application.Transpose(d.items)
End Sub
'实例二：求每种产品最后一次采购价
Sub last()
Dim arr()
Set d = CreateObject(“scripting.dictionary”)
arr = Range(“b1:c” & Cells(Rows.Count, 3).End(xlUp).Row)
For i = 1 To UBound(arr)
d(arr(i, 1)) = arr(i, 2) '如果字典中没有就添加，如果有就修改
Next
[i1].Resize(d.Count) = Application.Transpose(d.keys)
[j1].Resize(d.Count) = Application.Transpose(d.items)
End Sub
Sub xp()
dd = Split(“1,2,3,4”, “,”) '拆分函数split
jj = Join(dd, “*”) '合并函数join
End Sub
'实例三：重点，分类并计数出现次数，分类并求总和
Sub 分类计数()
Dim arr1
Set d = CreateObject(“scripting.dictionary”)
arr = Range(“b2:b” & Cells(Rows.Count, 2).End(xlUp).Row)
For Each rng In arr '逐个取值
i = d(rng) '赋值i=key为rng的对应item值，如果rng值第一次出现则为""
d(rng) = d(rng) + 1 '开始计数，对应key为rng的item进行累加，并添加唯一存在的key
i = d(rng) '赋值i=key值为rng的对应item值
Next
[e1].Resize(d.Count) = Application.Transpose(d.keys)
[f1].Resize(d.Count) = Application.Transpose(d.items)
End Sub
Sub 分类求和()
Dim arr1
Set d = CreateObject(“scripting.dictionary”)
arr = Range(“b2:c” & Cells(Rows.Count, 2).End(xlUp).Row)
For i = 1 To UBound(arr) '逐个取值
d(arr(i, 1)) = d(arr(i, 1)) + arr(i, 2) '累加key为相同值的item，并添加唯一存在的key
Next
[e8].Resize(d.Count) = Application.Transpose(d.keys)
[f8].Resize(d.Count) = Application.Transpose(d.items)
End Sub
'实例四: 应用字典技术快速索引条目
Sub tes到顶t() '条目数组用法
Set d = CreateObject(“scripting.dictionary”)
With Sheets(“data”)
arr = .Range(“a2:e” & .Cells(Rows.Count, 1).End(xlUp).Row)
End With
For i = 1 To UBound(arr)
d(arr(i, 1)) = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5)) '添加key为arr(i,1），对应item为组合后的数组
j = d(arr(i, 1))
Next
For Each rngc In Range(“a3:a” & Cells(Rows.Count, 1).End(xlUp).Row)
rngc.Offset(0, 1).Resize(1, 4) = d(rngc.Value)
Next
End Sub
'正则：后期绑定 Set regex = CreateObject("VBScript.RegExp")
Sub testdddc()
Set regx = CreateObject(“vbscript.regexp”)
sr = “aabcabcbac”
regx.Global = True 'Global属性：查找范围：true全部查找，false只查找第1个，默认false
regx.Pattern = “a” 'Pattern属性：书写正则表达式，默认为""
'----------------------------------
Set k = regx.Execute(sr) 'Execute方法：返回匹配成功的结果，是一个对象
For Each m In k
MsgBox m.Value '将匹配成功能的结果循环出来
Next
'----------------------------------
n = regx.Replace(sr, “-”) 'Replace方法：将匹配成功的结果做替换。
MsgBox n
'----------------------------------
End Sub
'正则表达式之普通字符
Sub test11111()
Set regx = CreateObject(“vbscript.regexp”) '设定regx为一个正则对象
With regx 'with语句
.Global = True '搜索全部匹配对象
.Pattern = “消售” '正则表达式为“消售”
Set rng = Range(“a2:a” & Cells(Rows.Count, 1).End(xlUp).Row) '将数组赋给rng
For Each rn In rng '按顺序取数组rng里的每一项
n = n + 1
Cells(n + 1, 1) = .Replace(rn.Value, “销售”) '单元格的值等于替换成“销售”的值
Next
End With '结束with语句
End Sub
'正则表达式元字符
'\d 匹配一个数字字符。
'
'\D 匹配一个非数字字符。
'
'\w 匹配包括下划线的任何单词字符。"A-Za-z0-9_"
'
'\W 匹配任何非单词字符。
'
'\s 匹配任何空白字符，包括空格、制表符、换页符等等。
'
'\S 匹配任何非空白字符。
'
'\b 匹配一个单词边界，也就是指单词和空格间的位置。
'
'\B 匹配非单词边界。
'
'\n 匹配一个换行符。
'
'\r 匹配一个回车符。
'\t 匹配一个制表符。
'. 匹配除 "\n" 之外的任何单个字符。要匹配包括 '\n' 在内的任何字符
'\b实例：张三 张三丰 李四 李四光 张无忌 陈六 张三 张三 丰 张三杰 丰张三 张三
Sub 提取数字()
Set regx = CreateObject(“vbscript.regexp”) '设定regx为一个正则对象
With regx
.Global = True '查找全部匹配成功的
.Pattern = “\D” '匹配一个非数字字符
Dim rng As Object '申明变量rng为一个对象
For Each rng In [a1:a4] '在单元格A1:A4中顺序取值
Cells(rng.Row, 2) = .Replace(rng, “”) '单元格=将rng中匹配到的值替换掉后的值
Next '循环
End With
End Sub
Sub 提取字符()
Set regx = CreateObject(“vbscript.regexp”)
With regx
.Global = True
.Pattern = “\w” '匹配非单词字符
Dim rng As Object
For Each rng In [a1:a4]
Cells(rng.Row, 2) = .Replace(rng, “”)
Next
End With
End Sub
Sub 规范格式()
Set regx = CreateObject(“vbscript.regexp”)
With regx
.Global = True
.Pattern = “\s” '匹配任何空白字符
Dim rng As Object
For Each rng In [a1:a4]
Cells(rng.Row, 2) = .Replace(rng, “-”)
Next
End With
End Sub
'元字符量词
'？匹配前面的子表达式零次或一次
'+ 匹配前面的子表达式一次或多次。
'* 匹配前面的子表达式零次或多次。
'{n} n 是一个非负整数。匹配确定的 n 次。
'{n,} n 是一个非负整数。至少匹配n 次。
'{n,m} m 和 n 均为非负整数，其中n <= m。
' (pattern)： 匹配 pattern 并获取这一匹配。（分组，将括号内的内容变成一个组，匹配的时候也会有组的匹配和全部的匹配）
' x|y ：匹配 x 或 y。（可选元素） (x与y是或者的意思）
'举例:
'="(VBA){2,}" '匹配vba重复两次的项目
'="经理|总裁|董事长" '匹配经理或者总裁或者董事长
'= "(张|李).*(平|明)"匹配姓名为张或者为李的，并且李或张至少出现0次以上，后面为平或者明的项目
'\d+-\d+[、.]? 匹配前面为数字，中间用-连接，后面为数字，数字后面有、或.或者两个都没有的(去编号)
'[] 在中括号中选若干字符之一
'[xyz] 字符集合。匹配所包含的任意一个字符。
'[^xyz] 负值字符集合。匹配未包含的任意字符。
'[a-z] 字符范围。匹配指定范围内的任意字符。
'[^a-z] 负值字符范围。匹配任何不在指定范围内的任意字符。
Sub tedt()
Set regx = CreateObject(“vbscript.regexp”)
With regx
.Global = True
.Pattern = “[a-zA-Z]+” '匹配a-z A-Z的任意一个字符，重复至少一次以上，也就是匹配任意单词
For Each rng In [a1:a3]
Set mat = .Execute(rng)
For Each m In mat
n = n + 1
Cells(rng.Row, n + 1) = m
Next
n = 0
Next
End With
End Sub
'^ 匹配输入字符串的开始位置。
'$ 匹配输入字符串的结束位置。
'= "^[A-Z]+\d+$"匹配开头为大写字母，结尾为数字的项目
'循环多个正则表达式
Sub 单词注释拆分() '执行多个正则表达式
Set regx = CreateObject(“vbscript.regexp”) '定义regx为一个正则对象
With regx
.Global = True '查找所有匹配项
For Each ar In Array(“[^a-z ]+”, “[a-z ]+”) '将多个正则表达式写在一个数组中
n = n + 1
.Pattern = ar '循环正则表达式
For Each rng In [a2:a251] '在单元格区域中逐个取值
Cells(rng.Row, n + 1) = .Replace(rng, “”) '匹配项进行替换
Next
Next
End With
End Sub
'一-龢 代表匹配一个汉字字符
'零宽断言 也就是匹配一个位置而非具体字符
'(?=...)从左向右匹配，匹配出满足正则条件的前一个位置
'(?!...)从左向右匹配，匹配出未满足正则条件的前一个位置
Sub teddst()
Set regx = CreateObject(“vbscript.regexp”) '创建一个正则对象
With regx
.Global = True
.Pattern = “(?=[川吉云粤])” '匹配川或者吉或者云或者粤的字符的前一个位置
For Each rng In [a2:a10] '在a2与a10中循环取数
Cells(rng.Row, 2) = .Replace(rng, “(中)”) '将匹配到的位置替换成中，因为匹配的是位置，所以确切说应该是插入
Next '循环
End With
End Sub
Sub 实例一()
With CreateObject(“vbscript.regexp”)
.Global = True
.Pattern = “：(?=副?总)” '匹配一个第一个字符为：副为零次或一次的后面且一定为总的位置
For Each rng In [a1:a7]
Cells(rng.Row, 2) = .Replace(rng, “：(高管)”)
Next
End With
End Sub
Sub 实例二()
With CreateObject(“vbscript.regexp”)
.Global = True
.Pattern = “\d+.?\d?(?=[元块])” '匹配一个后面跟着元或者块的数字
For Each rng In [b2:b6]
For Each m In .Execute(rng)
n = n + m * 1
Next
Cells(rng.Row, “c”) = n
n = 0
Next
End With
End Sub
Sub test的()
With CreateObject(“vbscript.regexp”)
.Global = True
.Pattern = “(?!^)(?=[a-z])” '匹配一个不是在开头，所有字母的前面位置
For Each rng In [a1:a11]
Cells(rng.Row, 2) = .Replace(rng, “-”)
Next
End With
End Sub
'前面我们已过知道"?"有三种：
'1 是量词{0,1}
'2 是非捕获型的匹配模式(?:)
'3 是环视结构(?=)(?!)
'今天学习第4种作用：
'当该字符紧跟在任何一个其他限制符 (*, +, ?, {n}, {n,}, {n,m}) 后面时是懒惰模式
'懒惰模式：尽可能少的匹配所搜索的字符串
'贪婪模式：尽可能多的匹配所搜索的字符串（默认模式）
'
Sub tesdfsaft()
With CreateObject(“vbscript.regexp”)
.Global = True
.Pattern = “第\d+章.*?[一-龢]+.+?\d+”
Set mat = .Execute([a1])
For Each m In mat
n = n + 1
Cells(n + 1, “c”) = m
Next
End With
End Sub
'分组 加上括号会匹配一个分组后的值
Sub 捕获分组值1()
Set regx = CreateObject(“vbscript.regexp”)
With regx
.Global = True
.Pattern = “([一-龢]{3,}) (\d+人)” '匹配前面为汉字而且至少三个，后面为数字加个汉字人，至少三个汉字分一组，多少人分一组
Set mat = .Execute([a1])
For Each m In mat
n = n + 1
Cells(n + 1, 3) = .Replace(m.Value, “$1”)
Cells(n + 1, 4) = .Replace(m.Value, “$2”)
Next
End With
End Sub
Sub 捕获分组值2()
Set regx = CreateObject(“vbscript.regexp”)
With regx
.Global = True
.Pattern = “([一-龢]{3,}) (\d+人)”
Set mat = .Execute([a1])
For i = 0 To mat.Count - 1
Cells(i + 2, 5) = mat(i).submatches(0)
Cells(i + 2, 6) = mat(i).submatches(1)
Next
End With
End Sub
Sub 提取()
n = 1
With CreateObject(“vbscript.regexp”)
.Global = True
.Pattern = “(\S+) (\S+) (\S) (\d+)(( \S+){1,3})” '分组提取身份证信息
Set mat = .Execute(Sheet3.[a1])
For Each m In .Execute(Sheet3.[a1])
n = n + 1
Cells(n, 1) = .Replace(m, “$1”)
Cells(n, 2) = .Replace(m, “$2”)
Cells(n, 3) = .Replace(m, “$3”)
Cells(n, 4) = .Replace(m, “$4”)
Cells(n, 5) = .Replace(m, “$5”)
Next
End With
End Sub
Sub 批量添加数值调节钮()
For Each 单元格 In Selection
ActiveSheet.Spinners.Add(单元格.Left + 单元格.Width, 单元格.Top, 单元格.Height, 单元格.Height).Select
Selection.LinkedCell = 单元格.Address
Next
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '选择发生变化时事件，需要放在sheet模块里
On Error Resume Next '忽略错误
If Target.Column = 2 Then '如果目标单元格是处于第二列
Me.Image1.Visible = True '图片1显示
Image1.Picture = LoadPicture(ThisWorkbook.Path & "\员工照片\" & Target.Offset(0, -1) & ".jpg") '图片1加载的路径为
Image1.Left = Target.Left + Target.Width '图片1的左侧为目标单元格的右侧
Image1.Top = Target.Top '图片1的顶部为目标单元格的顶部
Else
Me.Image1.Visible = False '图片1不显示
End If
End Sub
Range(“B:B”).Sort Range(“B1”), 1 '将B列按从小到大排序
Range(“B:B”).Sort Range(“B1”), 2 '将B列按从大到小排序
range(“B;B”).sort cells(1,1),1,cells(1,2),1,cells(1,3)三列同时排序
Range("C4:W2”)).Copy '复制区域
Range("C4:W2”).PasteSpecial Paste:=xlPasteValues '粘贴为数值型
Cells.EntireColumn.AutoFit '所有单元格自动调整列宽
Private Sub Workbook_Open() '自动储存/加密工作簿
On Error Resume Next
For kk = 1 To 4
dk = InputBox(“今天是” & Format(Date, “yyyy/mm/dd”) & Chr(10) & “请输入用户密码”)
If dk <> 123 Then
If kk = 3 Then
MsgBox “还有最后一次机会”
ElseIf kk = 4 Then
MsgBox “您输入的次数过多，将关闭此工作簿”: ThisWorkbook.Close: Exit Sub
Else
MsgBox “密码输入错误，请重新输入”
End If
Else
Dim mypath As String, fname As String '变量申明
fname = Format(Date, “yymmdd”) & ThisWorkbook.Name 'fname=当前日期&活动工作簿名
mypath = ThisWorkbook.Path & “/备份/” 'mypath路径为当前文件夹下的备份文件夹
ThisWorkbook.SaveCopyAs mypath & fname '保存
Exit Sub
End If
Next
End Sub
csng将文本型数字转化为数值型
cstr将数值型文字转化为文本型
me.controls("textbox"&i).value 可以将textbox变成变量
sub time()
application.ontime now+timevalue(“00:00:01”)，procedure:=“thisworkbook.t” 每隔1秒调用thisworkbook下的t程序
end sub
sub t
cell(1,1)=now
call time
end sub
if closemode=0 then cancel=1 禁止关闭窗体
application.wait(now+timevalue("00:00:05"))等待五秒以后继续执行程序
timer返回秒数
private sub userform-activate()’5秒以后自动关闭窗体并且倒计时提示
for i= 1 to 5
me.caption=6-i&"秒后将关闭窗口"
application.wait(now+timevalue("00:00:01"))
next
unload me
userform1.repaint 刷新窗体
在窗体的文本框添加[复制]右键菜单，代码如下：
Private Sub TextBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then
With Application.CommandBars.Add("Dicky", 5)
With .Controls.Add(1)
.Caption = "复制"
.OnAction = "AAA"
End With
.ShowPopup
.Delete
End With
End If
End Sub
textbox1.setfouse 将光标定位到textbox1内
With ListBox1
.AddItem
.List(.ListCount - 1, 0) = “asdf”
.List(.ListCount - 1, 1) = “ew”
.List(.ListCount - 1, 2) = “hgd”
End With
Sub 提取文件夹名称()
Dim fs As Object
n = 1
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder("E:\论坛工作资料")
For Each fd In f.subfolders
Cells(n, 1) = fd.Name
n = n + 1
Next
Set f = Nothing
Set fs = Nothing
End Sub
'文件夹操作()
'1 判断文件夹是否存在
'dir函数的第二个参数是vbdirectory时可以返回路径下的指定文件和文件夹，如果结果为""，则表示不存在。
Sub w1()
If Dir(ThisWorkbook.Path & “\Test”, 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
End Sub
634
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
