第40集：正则表达式4
小括号的作用
Option Explicit
'()
'可以让括号内作为一个整体
Sub t29()
Dim regx As New RegExp
Dim sr
sr = "A3A3QA3A37BDFEA387A8"
With regx
.Global = True
.Pattern = "(A3){2}" '相当于A3A3
Debug.Print .Replace(sr, "")
End With
End Sub
'取匹配结果的时候，括号中的表达式可以用 \数字引用
Sub t30()
Dim regx As New RegExp
Dim sr
sr = "A3A3QA3A37BDFEA387A8"
With regx
.Global = True
.Pattern = "((A3){2})Q\1" 'A3A3QA3A3
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"
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+(?=元)." '查找任意多数字后的元，查找到后从元以前开始查找,查找和\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}$"
Set mat = .Execute(sr)
For Each m In mat
Debug.Print m
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+元|\d+块"
Set mat = .Execute(sr)
For Each m In mat
Debug.Print m
Next m
End With
End Sub
第41集：正则表达式5
Sub 按钮1_单击()
Dim regx As New RegExp
Dim sr, x, mat, m
For x = 2 To Range("a65536").End(xlUp).Row
sr = Cells(x, 1)
With regx
.Global = True
.Pattern = Cells(x, 2)
If Cells(x, 5) = 1 Then
Cells(x, 3) = .Replace(sr, "")
Else
If .test(sr) = False Then
Cells(x, 3) = "没有匹配的"
Else
Cells(x, 3) = .Execute(sr)(0)
End If
End If
End With
Next x
End Sub
第42集：数据类型转换
数据类型
Option Explicit
'1 数据类型综述
'在VBA中的数据类型有整数、文本、对象等类型。这些不同的类型有着特定的作用，在进行运算时也会占用
'不同大小的内存，所以我们在编写程序时为了提高运行效率，一般都要定义数据的类型。
'2 数据类型对程序运行的影响
'byte 占用1个字节
'integer,boolean 占用2个字节
'long,single 占用4个字节
'Double,Currency,date 占用8个字节
'object 占用4个字节
'string(不定长) 占用10+字符长度个字节
'String(定长) 占用字符串长度个字节
'Variant(任意数字类型) 占用16个字节
'Variant(字符串) 占用24+字符串长度个字节
Sub sss1()
Dim x As Long
Dim t
'Dim k1 As Byte '用时0.03125s
Dim k
'Dim k1 As Integer '用时0.15625s
Dim k1 As String '用时0.203125s
k = 1
t = Timer
For x = 1 To 1000000
k1 = k
Next x
Debug.Print Timer - t
End Sub
数据类型检查
'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
Sub 速度测试()
Dim t
Dim x As Long
t = Timer
For x = 1 To 100000
'If Range("a1") = "" Then '用时0.81
' If Len(Range("a1")) = 0 Then '0.84
' If VBA.IsEmpty(Range("a1")) Then '速度 0.79
'If VBA.TypeName(Range("a1").Value) = Empty Then '0.84
End If
Next x
Debug.Print Timer - t
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
Sub 速度测试2()
Dim t
Dim x As Long
t = Timer
For x = 1 To 100000
'If VBA.IsNumeric(Range("a1")) Then '用时0 0.79
'If Application.WorksheetFunction.IsNumber(Range("A1")) Then '0.9218
'If VBA.TypeName(Range("A1").Value) = "Double" Then '速度 0.84
End If
Next x
Debug.Print Timer - t
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
数据类型转换
Option Explicit
'一、类型转换函数：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
第43集：时间与日期
'1 计算两个日期相隔天数,月数,年数,小时,分种,秒
Sub tt1()
Dim d1, d2 As Date
d1 = #11/21/2011#
d2 = #12/1/2011#
Debug.Print "相隔" & (d2 - d1) & "天"
Debug.Print "相隔" & DateDiff("d", d1, d2) & "天"
Debug.Print "相隔" & DateDiff("m", d1, d2) & "月"
Debug.Print "相隔" & DateDiff("yyyy", d1, d2) & "年"
Debug.Print "相隔" & DateDiff("q", d1, d2) & "季"
Debug.Print "相隔" & DateDiff("w", d1, d2) & "周"
Debug.Print "相隔" & DateDiff("h", d1, d2) & "小时"
Debug.Print "相隔" & DateDiff("n", d1, d2) & "分种"
Debug.Print "相隔" & DateDiff("s", d1, d2) & "秒"
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
'1 返回当前日期、时间（指本机系统设置的日期和时间）
Sub t1()
Debug.Print Date '返回当前日期
Debug.Print Time '返回当前时间
Debug.Print Now '返回当前日期+时间
End Sub
'2 格式化显示日期
Sub t2()
Debug.Print Format(Now, "yyyy-mm-dd")
Debug.Print Format(Now, "yyyy年mm月dd日")
Debug.Print Format(Now, "yyyy年mm月dd日 h:mm:ss")
Debug.Print Format(Now, "d-mmm-yy") '英文月份
Debug.Print Format(Now, "d-mmmm-yy") '英文月份
Debug.Print Format(Now, "aaaa") '中文星期
Debug.Print Format(Now, "ddd") '英文星期前三个字母
Debug.Print Format(Now, "dddd") '英文星期完整显示
End Sub
'3 根据年月日返回日期
Sub t3()
Debug.Print VBA.DateSerial(2011, 10, 1)
End Sub
'4 根据小时分种返回时间
Sub t4()
Debug.Print VBA.TimeSerial(1, 2, 1)
End Sub
'5 返回年月日小时分秒
Sub t5()
Dim d
d = "2011-10-28 01:10:03"
Debug.Print Year(d) & "年"
Debug.Print Month(d) & "月"
Debug.Print Day(d) & "日"
Debug.Print Hour(d) & "时"
Debug.Print VBA.Minute(d) & "分"
Debug.Print Second(d) & "秒"
End Sub
计时器ontime
Option Explicit
Dim k
Sub ttt1()
Application.OnTime TimeValue("15:46:00"), "A"
End Sub
Sub a()
MsgBox "test"
End Sub
Sub ttt2()
Application.OnTime Now + TimeValue("00:00:02"), "A"
End Sub
Sub 时间显示()
Dim x
If k = 1 Then
k = 0
End
End If
Range("a1") = Format(Now, "h:mm:ss")
Application.OnTime Now + TimeValue("00:00:01"), "时间显示"
x = DoEvents
End Sub
Sub 结束时间显示()
k = 1
End Sub
第45集：随机抽取之移形换位法
Option Explicit
Sub 随机挑选演示程序1()
Dim arr
Dim x As Integer, num As Integer, k As Integer
Range("c1:c10") = ""
Range("a1:a10") = Application.Transpose(Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J"))
For x = 1 To 10
num = (Rnd() * (10 - 1) + 1) \ 1
Range("a1:a10").Interior.ColorIndex = xlNone
Range("a" & num).Interior.ColorIndex = 6
Range("c" & x) = Range("a" & num)
Next x
End Sub
Sub 移形换位演示程序()
Dim arr
Dim x As Integer, num As Integer, k As Integer, sr As String
Range("c1:c10") = ""
Range("a1:a10") = Application.Transpose(Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J"))
For x = 1 To 10
num = (Rnd() * ((10 - x + 1) - 1) + 1) \ 1
Range("a1:a" & (10 - x + 1)).Interior.ColorIndex = xlNone
Range("a" & num).Interior.ColorIndex = 6
Range("c" & x) = Range("a" & num)
'下面开始换位
sr = Range("a" & num)
Range("a" & num) = Range("a" & (10 - x + 1))
Range("a" & (10 - x + 1)) = sr
Range("a" & (10 - x + 1)).Interior.ColorIndex = 1
Next x
End Sub
Sub 随机抽取字典法()
Dim d As Object
Dim arr, num As Integer, x As Integer, arr1(1 To 20000, 1 To 1) As String, t
t = Timer
Set d = CreateObject("scripting.dictionary")
arr = Range("a1:a20000")
For x = 1 To 20000
100:
num = Rnd() * (20000 - 1) + 1
If d.exists(num) Then
GoTo 100
Else
d(num) = ""
arr1(x, 1) = arr(num, 1)
End If
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 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
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
第46集：组合之递归算法
Option Explicit
Dim k As Long
'递归基础
'1 什么是递归？
'递归就是自已调用自已。
'2,用递归有什么好处？
'简化代码，让程序更简捷。特别是在循环层数不定的情况下可以大大简单代码。
'3,递归有什么坏处？
'因为递归在使用时会产生大量储存临时信息的“栈”（按先进先出储存信息），所以运行效果比较低，所以一般不建议使用递归设计程序
'2 例: 计算4的阶乘 (4 * 3 * 2 * 1 = 24)
Sub 一般方法()
Dim k, x
k = 1
For x = 4 To 1 Step -1
k = k * x
Next x
MsgBox k
End Sub
Sub 递归1()
MsgBox s(5)
End Sub
'函数法
Function s(n As Integer) As Integer
If n = 1 Then
s = 1
Else
s = n * s(n - 1)
End If
End Function
Sub 递归2()
k = 1
s2 4
MsgBox k
End Sub
'sub过程法
Sub s2(n As Integer)
' Dim m
If n > 0 Then
k = k * n
'm = n
s2 n - 1
End If
End Sub
'3 例：计算1+2+3+.5
Sub 递归3()
k = 0
add5 1
'MsgBox k
End Sub
Sub add5(n As Integer)
If n < 5 Then
k = k + n
add5 n + 1
End If
End Sub
Option Explicit
Dim arr1(1 To 100, 1 To 1) '把分组后的结果放在arr1中
Dim k As Integer '作为arr1填充时的行数
Sub 组合()
Dim arr
k = 0
Erase arr1
arr = Range("a2:a" & Range("a65536").End(xlUp).Row)
zuhe arr, 1, "", 0
Range("c2").Resize(100) = ""
Range("c2").Resize(k) = arr1
End Sub
Sub zuhe(arr, x, sr, y)
'arr 把源数组导入子过程
'x 递归的索引号
'sr 连接的字符串
'y 连接的次数
If y = [b2] Then
k = k + 1
arr1(k, 1) = sr
Exit Sub
End If
If x < UBound(arr) + 1 Then
zuhe arr, x + 1, sr & arr(x, 1), y + 1
zuhe arr, x + 1, sr, y
End If
End Sub
Option Explicit
Dim arr1(1 To 10000, 1 To 1) As String '公式表达式放在arr1中
Dim k As Integer '作为arr1填充时的行数
Dim g As Integer, h As Integer
Dim arr
Dim k1
Sub 组合()
k = 0
Dim t
t = Timer
Erase arr1
arr = Range("a2:a" & Range("a65536").End(xlUp).Row)
g = [b2]
h = [c2]
zuhe 1, 0, "", 0
Range("d2").Resize(k) = arr1
[e1] = k1
MsgBox "找到 " & k & " 个解! 花费" & Format(Timer - t, "0.00") & "秒"
End Sub
Sub zuhe(x%, z%, sr$, gg As Byte)
If z + arr(x, 1) = h And gg = g - 1 Then
k = k + 1
arr1(k, 1) = sr & arr(x, 1) & "=" & h
Exit Sub
End If
If x < UBound(arr) And z < h Then
If z + arr(x, 1) < h Then
zuhe x + 1, z + arr(x, 1), sr & arr(x, 1) & "+", gg + 1
End If
zuhe x + 1, z, sr, gg
End If
End Sub
Sub 循环法()
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim t
Dim arr(1 To 1000, 1 To 1) As String
Dim q As Long, q1 As Long
t = Timer
For x = 1 To 97
For y = x + 1 To 98
For z = y + 1 To 99
q1 = q1 + 1
If x + y + z = 54 Then
q = q + 1
arr1(q, 1) = x & "+" & y & "+" & z & "=54"
End If
Next z, y, x
Range("e2").Resize(10000) = ""
Range("e2").Resize(q) = arr1
MsgBox Timer - t
End Sub
任意多个数之和
Option Explicit
Dim arr1(1 To 10000, 1 To 1) As String '公式表达式放在arr1中
Dim k As Integer '作为arr1填充时的行数
Dim g As Integer, h As Integer
Dim arr
Dim k1
Sub 组合()
k = 0
Dim t
t = Timer
Erase arr1
arr = Range("a2:a" & Range("a65536").End(xlUp).Row)
g = [b2]
h = [c2]
zuhe 1, 0, ""
Range("d2").Resize(k) = arr1
[e1] = k1
MsgBox "找到 " & k & " 个解! 花费" & Format(Timer - t, "0.00") & "秒"
End Sub
Sub zuhe(x%, z%, sr$)
If z + arr(x, 1) = h Then
k = k + 1
arr1(k, 1) = sr & arr(x, 1) & "=" & h
Exit Sub
End If
If x < UBound(arr) And z < h Then
If z + arr(x, 1) < h Then
zuhe x + 1, z + arr(x, 1), sr & arr(x, 1) & "+"
End If
zuhe x + 1, z, sr
End If
End Sub
递归进阶
Sub jin(n)
If n < 4 Then
jin n + 1
jin n + 1
End If
End Sub
Sub 调用jin()
jin 1
End Sub
第47集：VBA程序提速
一_减少对象的调用
'调用对象是非常非常的耗费资源的，所以一定要尽可能的少调用对象。包括：
'工作簿、工作表、单元格以及外引用对象。
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倍
二_减少计算次数
Option Explicit
'程序的运算速度和计算次数有着很大的关系，所以要尽可能的减少计算的次数
'能在循环外计算出结果的，就不要在循环内计算。
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
三_禁止闪屏
Option Explicit
'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
四_增加变量的声明类型
Option Explicit
Sub 没声明变量类型()
Dim arr, brr(1 To 6800, 1 To 3), i, s, x
Dim t
t = Timer
arr = Range("a1").CurrentRegion
For i = 1 To UBound(arr)
s = Replace(Replace(arr(i, 1), "(", "*'"), ")", "")
brr(i, 1) = Split(s, "*")(0)
brr(i, 2) = Split(s, "*")(1)
brr(i, 3) = Split(s, "*")(2)
Next
[c1].Resize(UBound(arr), 3) = ""
[c1].Resize(UBound(arr), 3) = brr
MsgBox Timer - t
End Sub
Sub 变量声明后()
Dim arr, brr(1 To 6800, 1 To 3) As String, i%, s$, x As Integer
Dim t
t = Timer
arr = Range("a1").CurrentRegion
For i = 1 To UBound(arr)
s = Replace(Replace(arr(i, 1), "(", "*'"), ")", "")
brr(i, 1) = Split(s, "*")(0)
brr(i, 2) = Split(s, "*")(1)
brr(i, 3) = Split(s, "*")(2)
Next
[c1].Resize(UBound(arr), 3) = ""
[c1].Resize(UBound(arr), 3) = brr
MsgBox Timer - t
End Sub
Sub 拆分数组()
Dim arr, brr1(1 To 6800, 1 To 1) As String, brr2(1 To 6800, 1 To 1) As Integer, brr3(1 To 6800, 1 To 1) As String, i%, s$, x As Integer
Dim t
t = Timer
arr = Range("a1").CurrentRegion
For i = 1 To UBound(arr)
s = Replace(Replace(arr(i, 1), "(", "*'"), ")", "")
brr1(i, 1) = Split(s, "*")(0)
brr2(i, 1) = Split(s, "*")(1)
brr3(i, 1) = Split(s, "*")(2)
Next
[c1].Resize(UBound(arr), 3) = ""
[c1].Resize(UBound(arr), 1) = brr1
[d1].Resize(UBound(arr), 1) = brr2
[E1].Resize(UBound(arr), 1) = brr3
MsgBox Timer - t
End Sub
五_减少工作表函数的使用
'调用工作表函数可以让代码更简捷,但速度却不理想..减少对工作表函数的调用也是提升程序速度的方法之一
Sub 统计次数()
Dim x, arr, k, t, Y
t = Timer
For Y = 1 To 10
arr = Range("a1:a6800")
For x = 1 To UBound(arr)
If InStr(arr(x, 1), "加10分") > 0 Then
k = k + 1
End If
Next x
Next Y
Debug.Print Timer - t & "秒"
End Sub
Sub 使用函数变慢()
Dim x, arr, k, t, Y
t = Timer
For Y = 1 To 10
arr = Range("a1:a6800")
k = Application.CountIf([a:a], "*加10分*")
Next Y
Debug.Print Timer - t & "秒"
End Sub
'***************************************************
Sub 用函数()
Dim t
Dim arr
arr = Range("a1:c6800")
t = Timer
Range("f1:f6800") = Application.Index(arr, , 3)
Debug.Print Timer - t
End Sub
Sub 用循环()
Dim arr1(1 To 10000, 1 To 1), x As Integer, Y As Integer, k As Integer, t
Dim arr
arr = Range("a1:c6800")
t = Timer
For x = 1 To 6800
arr1(x, 1) = arr(x, 3)
Next x
Range("f1:f6800") = arr1
Debug.Print Timer - t
End Sub
六_减少VBA函数的使用
Sub 用VBA函数算整除()
Dim x, t, k
t = Timer
For x = 1 To 1000000
k = Int(10000 / 3)
Next x
Debug.Print Timer - t
End Sub
Sub 用整除运算符()
Dim x, t, k
t = Timer
For x = 1 To 1000000
k = 10000 \ 3
Next x
Debug.Print Timer - t
End Sub
七_用静态数组替换动态
Sub 动态数组()
Dim arr, brr(), t, k As Integer, x As Long
t = Timer
ReDim brr(1 To 1)
arr = Range("A1:A13000")
For x = 1 To UBound(arr)
If arr(x, 1) Like "*64-10*" Then
k = k + 1
ReDim Preserve brr(1 To k)
brr(k) = arr(x, 1)
End If
Next x
Range("f1").Resize(k) = Application.Transpose(brr)
Debug.Print Timer - t
End Sub
Sub 静态数组()
Dim arr, brr(1 To 10000, 1 To 1) As String, t, k As Integer, x As Long, Y
t = Timer
arr = Range("A1:A13000")
For x = 1 To UBound(arr)
If arr(x, 1) Like "*64-10*" Then
k = k + 1
brr(k, 1) = arr(x, 1)
End If
Next x
Range("D1").Resize(k) = brr
Debug.Print Timer - t
End Sub
八_填充前先清空
Sub 变量声明后()
Dim arr, brr(1 To 20400, 1 To 3) As String, i%, s$, x As Integer
Dim t
t = Timer
arr = Range("a1").CurrentRegion
For i = 1 To UBound(arr)
s = Replace(Replace(arr(i, 1), "(", "*'"), ")", "")
brr(i, 1) = Split(s, "*")(0)
brr(i, 2) = Split(s, "*")(1)
brr(i, 3) = Split(s, "*")(2)
Next
[c1].Resize(UBound(arr), 3) = ""
[c1].Resize(UBound(arr), 3) = brr
Debug.Print Timer - t
End Sub
九_批量替代个体
Sub 隐藏工作表()
Dim x As Integer, t
显示工作表
t = Timer
For x = 1 To Sheets.Count
If Sheets(x).Name Like "Sh*" Then
Sheets(x).Visible = False
End If
Next x
Debug.Print Timer - t
End Sub
Sub 隐藏工作表2()
Dim x As Integer, t, arr(), k
显示工作表
t = Timer
For x = 1 To Sheets.Count
If Sheets(x).Name Like "Sh*" Then
k = k + 1
ReDim Preserve arr(1 To k)
arr(k) = Sheets(x).Name
End If
Next x
Sheets(arr).Visible = False
Debug.Print Timer - t
End Sub
Sub 显示工作表()
Dim x
For x = 1 To Sheets.Count
If Sheets(x).Name Like "Sh*" Then
Sheets(x).Visible = True
End If
Next x
End Sub
十_减少循环次数
'减少循环次数是最直接的优化速度方法,但操作起来有难度,需要学习相关的知识.如:
'1 利用VBA字典.在查找时替代循环查找.相关方法参见VBA80集字典部分
'2 学习VBA算法,减少不必要的循环和运算.如:第45集的换位算法,和29集下棋法,
' 另外,象26集的排序算法,也是通过排除不必要的运算和循环来加快程序运行速度
十一_巧妙填充公式
'向单元格输入公式,如果是连续的,就可以用填充的方法来完成.
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 = TimerS
Cells(2, "e") = "=C2*D2"
Range("e2:e2000").FillDown
Debug.Print Timer - t
End Sub
第48集：基本操作
'遍历指定文件夹中的文件
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
'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
第49集：文件夹遍历
FileSearch
Sub test3()
Dim wb As Workbook
Dim i As Long
Dim t
Dim arr()
t = Timer
ActiveSheet.UsedRange = ""
With Application.FileSearch '调用fileserch对象
.NewSearch '开始新的搜索
.LookIn = ThisWorkbook.path '设置搜索的路径
.SearchSubFolders = True '搜索范围包括 LookIn 属性指定的文件夹中的所有子文件夹
.Filename = "*.xl*" '设置搜索的文件类型
If .Execute() > 0 Then '如果找到文件
ReDim arr(1 To .FoundFiles.Count, 1 To 1)
For i = 1 To .FoundFiles.Count
arr(i, 1) = .FoundFiles(i) '把找到的文件放在单元格里
Next i
Else
MsgBox "没找到文件"
End If
End With
Range("a1").Resize(i - 1) = arr
MsgBox Timer - t
End Sub
父子转换法
Sub 父子转换法()
'On Error Resume Next
Dim 父亲(1 To 10000) As String
Dim f, i, k, f2, f3, x
Dim arr1(1 To 100000, 1 To 1) As String, q As Integer
Dim t
t = Timer
父亲(1) = ThisWorkbook.path & "\"
i = 1: k = 1
Do While i < UBound(父亲)
If 父亲(i) = "" Then Exit Do
f = Dir(父亲(i), vbDirectory)
Do
If InStr(f, ".") = 0 And f <> "" Then
k = k + 1
父亲(k) = 父亲(i) & f & "\"
End If
f = Dir
Loop Until f = ""
i = i + 1
Loop
'*******下面是提取各个文件夹的文件***
For x = 1 To UBound(父亲)
If 父亲(x) = "" Then Exit For
f3 = Dir(父亲(x) & "*.*")
Do While f3 <> ""
q = q + 1
arr1(q, 1) = 父亲(x) & f3
f3 = Dir
Loop
Next x
ActiveSheet.UsedRange = ""
Range("a1").Resize(q) = arr1
MsgBox Format(Timer - t, "0.00000")
End Sub
Sub 父子转换法演示程序()
Dim 父亲(1 To 10000) '存放所有文件夹名称及其路径
Dim f, i, k, f2, f3, x
Dim arr1(1 To 100000, 1 To 1) '存放查找到的所有文件
Dim q As Integer
父亲(1) = ThisWorkbook.path & "\" '初始化arr，先赋一个值
Cells(1, 1) = 父亲(1)
i = 1: k = 1 '初始化i和k的值
Do While i <= k '循环条件是i小于等于文件夹的个数
f = Dir(父亲(i), vbDirectory)
Range("a" & i).Interior.ColorIndex = 6
Do
If InStr(f, ".") = 0 And f <> "" Then
k = k + 1
父亲(k) = 父亲(i) & f & "\"
Cells(k, 1) = 父亲(k)
End If
f = Dir
Loop Until f = ""
Range("a" & i).Interior.ColorIndex = xlNone
i = i + 1
Loop
'*******下面是提取各个文件夹的文件***
For x = 1 To UBound(父亲)
If 父亲(x) = "" Then Exit For
f3 = Dir(父亲(x) & "*.*")
Do While f3 <> ""
q = q + 1
arr1(q, 1) = 父亲(x) & f3
f3 = Dir
Loop
Next x
' ActiveSheet.UsedRange = ""
Range("b1").Resize(q) = arr1
End Sub
实例
Sub 提取文件信息()
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) = ThisWorkbook.path & "\"
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) & "*.*")
Do While f3 <> ""
q = q + 1
arr1(q, 6) = arr(x) & f3
Set myfile = fso.GetFile(arr1(q, 6))
arr1(q, 1) = f3
arr1(q, 2) = myfile.Size
arr1(q, 3) = myfile.DateCreated
arr1(q, 4) = myfile.DateLastModified
arr1(q, 5) = myfile.DateLastAccessed
f3 = Dir
Loop
Next x
Range("a2").Resize(1000, 6) = ""
Range("a2").Resize(q, 6) = arr1
End Sub
第50集：VBA压缩文件和解压缩
一_压缩文件
'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
三_添加压缩密码
'-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
Sub RarFile10() '多个文件压在一起,并添加密码,看不到文件列表
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 -hp123 " & myRAR & " " & Myfile
Result = Shell(FileString, vbHide) '执行压缩
End Sub
四_压缩后删除源文件
'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
五_压缩时排除
Option Explicit
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 解压含密码的压缩包
指定类型或文件解压
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 & " e " & myRAR & " " & "说明.txt" 'rar程序的A命令压缩文件的字符串
Result = Shell(FileString, vbHide) '执行压缩
End Sub
'在当前文件夹，从全部的 RAR 压缩文件解压所有的 *.doc 文件到当前文件夹
'
'WinRAR e * .RAR * .doc
获得rar的安装路径
Function GetSetupPath(AppName As String)
Dim WSH As Object
Set WSH = CreateObject("Wscript.Shell")
GetSetupPath = WSH.RegRead("HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\App Paths\" & AppName & "\Path")
Set WSH = Nothing
End Function
Sub 测试()
Debug.Print GetSetupPath("Winrar.exe")
End Sub
第51 txt 读写
Option Explicit
'Open 文件名 for 打开方式 as 文件编号
'打开方式:
'Input ：只能读，不能写
'Append：允许读也允许写，如果存在文件就追加记录，如果没有就新建文件
'Output：可以读，也可以写。但总会把原来的同名文件删除，再新建一个
'读取txt文件内容方法
'input：从文件中读取指定数量的字符。
'Input #：把数据读出放在变量里，变量用逗号分隔
'Line Input #：取出完整的一行
'向文件中写入数据
'write #：向文件中写入值，值用引号引起来。如果想在同一行中继续写入，可以在前一次写时结尾添加“;”号
'Print #：向文件中写入值，如果想在同一行中继续写入，可以在前一次写时结尾添加“;”
'字符的间隔符
'Spc(n)表示输入n个空字符
Option Explicit
'一、用Print写入
'1 分行输入
Sub t1()
Dim f As String
f = ThisWorkbook.path & "\a.txt"
Open f For Output As #1
Print #1, "产品名称"
Print #1, Date
Close #1
End Sub
'2 在同一行输入
Sub t2()
Dim f As String
f = ThisWorkbook.path & "\a.txt"
Open f For Output As #1
Print #1, "产品名称";
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
End Sub
Sub t6()
Dim f As String
f = ThisWorkbook.path & "\a.txt"
Open f For Output As #1
Write #1, "产品名称";
Write #1, 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 '这里逗号等同于"; "(分号)"
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
Write #1, Date; 1 = 1, 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
写入实例
Option Explicit
'将sheet2表中的数据写入到文本文本中
Sub 转换成txt文件()
Dim f, arr, x, y, k
f = ThisWorkbook.path & "\ruku.txt"
arr = Sheets("sheet2").Range("a1:e6")
Open f For Output As #1
For x = 1 To UBound(arr)
For y = 1 To UBound(arr, 2)
If y = UBound(arr, 2) Then
Print #1, arr(x, y)
Else
If VBA.IsNumeric(arr(x, y)) Then
k = 12 - Len(arr(x, y)) - 2
ElseIf arr(x, y) Like "[A-Z]" Or VBA.IsDate(arr(x, y)) Then
k = 12 - Len(arr(x, y)) - 1
Else
k = 12 - Len(arr(x, y)) * 2
End If
Print #1, arr(x, y); Spc(k);
End If
Next y
k = 0
Next x
Close #1
End Sub
'示例2 记录打开和关闭时间
' 详见thisworkbook事件
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
第52集：Txt文件的读取
Input读取方式
Option Explicit
'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井读取方式
Option Explicit
'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写入()
On Error Resume Next
Dim f, arr, x, y, k
f = ThisWorkbook.path & "\ruku3.txt"
arr = Sheets("sheet2").Range("a1:e16")
Open f For Output As #1
For x = 1 To UBound(arr)
For y = 1 To UBound(arr, 2)
If y = UBound(arr, 2) Then
Write #1, arr(x, y)
Else
Write #1, arr(x, y);
End If
Next y
k = 0
Next x
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读取方式
Option Explicit
'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
txt文件的读写
Option Explicit
'Open 文件名 打开方式 as 文件编号
'打开方式:
'Input ：只能读，不能写
'Append：允许读也允许写，如果存在文件就追加记录，如果没有就新建文件
'Output：可以读，也可以写。但总会把原来的同名文件删除，再新建一个
'读取txt文件内容方法
'input：从文件中读取指定数量的字符。
'Input #：把数据读出放在变量里，变量用逗号分隔
'Line Input #：取出完整的一行
'向文件中写入数据
'write #：向文件中写入值，值用引号引起来。如果想在同一行中继续写入，可以在前一次写时结尾添加“;”号
'Print #：向文件中写入值，如果想在同一行中继续写入，可以在前一次写时结尾添加“;”
'字符的间隔符
'Spc(n)表示输入n个空字符
拆分文本文件示例
Option Explicit
Sub 拆分()
Dim f, y1, y2, y3, y4, y5
Dim arr(1 To 5) '存放标题行
Dim k '判断第一行
f = ThisWorkbook.path & "\ruku3.txt"
Open f For Input As #1
Do While Not EOF(1)
Input #1, y1, y2, y3, y4, y5
k = k + 1
If k = 1 Then
arr(1) = y1: arr(2) = y2: arr(3) = y3: arr(4) = y4: arr(5) = y5
Else
Open ThisWorkbook.path & "\拆分示例\" & y2 & ".txt" For Append As #2
If LOF(2) = 0 Then
Write #2, arr(1), arr(2), arr(3), arr(4), arr(5)
Write #2, y1, y2, y3, y4, y5
Else
Write #2, y1, y2, y3, y4, y5
End If
Close #2
End If
Loop
Close #1
End Sub
第53集：窗体与控件基础
窗体的导出和导入
Option Explicit
'有时候我们需要把一个EXCEL工程的窗体及其控件导入到别一个窗体中,或者把窗体内容保存起来.那
'么可以在窗体上右键--导出文件,就可以另存为窗体格式的文件,导入是利用右键的"导入文件功能,工选
'取窗体格式的文件导入即可.
窗体的使用
Option Explicit
'一、窗体的使用
'1 窗体的插入和启用
'插入菜单--用户窗体
'工程窗口中右键--插入--用户窗体
'2 窗体的运行
'手工点运行按钮(快捷键F5)
'用代码执行
Sub 显示窗体()
入库单.Show
End Sub
'3 窗体的关闭
'手工点关闭按钮
'用代码执行关闭
'详见窗体
'4 窗体的显示设置
'A 窗体的标题
'设置Captain的值
'B 窗体的背景色
'设置BackColor的颜色值
'示例详见测试窗体click事件
'C 窗体的背景图片
'UserForm1.Picture=loadpicture(图片路径)
'UserForm1.PictureAlignment
'UserForm1.PictureSizeMode
'UserForm1.PictureTiling
'5 窗体的位置和大小
'height 窗体高
'left top 窗体与excel窗口左边或顶边之间的距离
'Width 窗体的宽度
'StartupPosition ' 设置窗体启动时的位置
'6 窗体显示的一些行为
'ShowModal 设置在窗体显示时,是否可以编辑单元格区域
'7 窗体的删除
'选中窗体，右键，移除。。。
控件的使用
Option Explicit
'二 控件的使用
'1 控件的插入
'控件的插入是通过控件工具箱来实现的
'控件工具箱中显示的是常用控件,如果想加载其他控件,
'2 控件的删除
'选取后工直接删除即可
'3 控件的格式对齐与分布
'可以通过格式菜单来完成
'4 控件的tab顺序
'按tab键后的控件选取顺序
'5 控件的循环
'在窗体内表示所有控件的集合是controls
'Controls(序号)
'Controls("控件名称")
'6 判断控件的类型
'用typename函数来判断一个控件的类型
userform1
Option Explicit
Private Sub UserForm_Click()
Unload Me
End Sub
'me是什么?
'me是宿主,在窗体代码窗口的使用Me代表窗体对象,在工作表代码窗口中代码工作表对象
测试窗体
Option Explicit
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
Private Sub TextBox1_Change()
End Sub
Private Sub UserForm_Click()
Dim 红 As Byte, 绿 As Byte, 蓝 As Byte
红 = Rnd() * 255 \ 1
绿 = Rnd() * 255 \ 1
蓝 = Rnd() * 255 \ 1
Me.BackColor = RGB(红, 绿, 蓝)
End Sub
Show方法
Unload方法分别代表窗体的运行和关闭。
第54集：窗体事件
Option Explicit
'一 概述'窗体事件,是作用于窗体上的动作引发的程序的自动运行
'窗体中的事件
Private Sub UserForm_Activate()
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
第55集：标签、按钮
按钮控件示例窗体
'**********************按钮控件****************
'一 按钮显示
'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
Private Sub UserForm_Click()
End Sub
标签控件示例窗体
Option Explicit
'**********************按钮控件****************
'一 功能
'显示文本
'一 显示
'1 自动适应字体大小。
'AutoSize的属性设置为true可以自动调整大小以完全显示文字
'2 背景透明
'BackStyle值0为透明 1 不透明
'3 文字对齐
'TextAlign属性1左对齐2居中对齐3右对齐
'4 字体的自动换行
'WordWrap属性如果为True则自动换行(默认)
Private Sub UserForm_Click()
End Sub
第56集：文字框
输入窗口
Option Explicit
Dim d As Object
Private Sub UserForm_Initialize()
Dim arr, x
日期 = Date
Set d = CreateObject("scripting.dictionary")
arr = Sheets("sheet3").Range("G2:H4")
For x = 1 To UBound(arr)
d(arr(x, 1)) = arr(x, 2)
Next x
End Sub
Private Sub 金额_Change()
End Sub
Private Sub 数量_Exit(ByVal Cancel As MSForms.ReturnBoolean) '离开数量后就自动输入到单元格中
Dim myrow As Long, x
If VBA.IsNumeric(数量.Value) Then
With Sheets("sheet3")
myrow = .Range("a65536").End(xlUp).Row + 1
.Cells(myrow, 1) = 日期
.Cells(myrow, 2) = 商品
.Cells(myrow, 3) = 数量.Value
.Cells(myrow, 4) = 单价.Value
.Cells(myrow, 5) = 金额.Value
End With
商品 = ""
Else
MsgBox "数量不能为非数字，请重新输入"
Cancel = True
End If
' End If
End Sub
Private Sub 数量_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
End Sub
Private Sub 商品_Exit(ByVal Cancel As MSForms.ReturnBoolean) '根据商品查找单价
'提取商品单价
If d.Exists(商品.Value) Then
单价 = d(商品.Value)
Else
MsgBox "该商品单价不存在，请重新输入"
Cancel = True
End If
End Sub
Private Sub 数量_Change() '输入数量后自动计算金额
If VBA.IsNumeric(数量.Value) Then
金额 = 数量 * 单价
End If
End Sub
文本框窗体示例
Option Explicit
'**********************文字框控件***************
'一 显示
'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，当文字框输入字符数大于
'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
Private Sub UserForm_Click()
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
第57集：列表和组合框
概述
Private Sub UserForm_Initialize()
Dim arr
arr = Array("excel精英培训", "兰色幻想", "VBA80集", "第57集")
Me.ListBox1.List = arr
Me.ComboBox1.List = arr
End Sub
列表框示例窗体
Option Explicit
'列表框
'属性和方法
'1 ListStyle值为0时,样式为默认样式，无单选或多选框，如果为1时则有
'2 Selected(行数) 可以判断列表框中某行是否被选取
'3 ListCount 列表框的条目个数
'4 MultiSelect 属性值为0只能选一个，1可以用鼠标点击多选或取消,2需要按shift或ctrl才能多选
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 LB1_Click()
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
组合框示例窗体
Option Explicit
'组合框
'一 显示
'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时，必须输入组合框中含有的
第58集：单选复选和框架和多页
控件
Option Explicit
'************单选和复选框*************
Private Sub CommandButton1_Click()
Dim sr As String
If CheckBox1.Value = True Then sr = sr & " " & CheckBox1.Caption
If CheckBox2.Value = True Then sr = sr & " " & CheckBox2.Caption
If CheckBox3.Value = True Then sr = sr & " " & CheckBox3.Caption
TextBox3.Value = sr
End Sub
Private Sub OptionButton3_Click()
If Me.男.Value = True Then
TextBox3.Value = "男"
End If
End Sub
Private Sub OptionButton4_Click()
If Me.女.Value = True Then
TextBox3.Value = "女"
End If
End Sub
Private Sub Frame1_Click()
End Sub
Private Sub Image1_Click()
End Sub
'**********滚动条与*微调按钮****************
'一 常用方法和属性
'1 设置最大值和最小值
'Max属性
'min属性
'2 步长(每点击两边按钮和滑块增加或减少的步长)
'largechange属性，只用于滚动条，点击一次中间增加或减少的数
'smallchange属性，点击一次按变化的数
'二 事件
Private Sub ScrollBar1_Change()
TextBox1.Value = ScrollBar1.Value
End Sub
Private Sub SpinButton1_Change()
'TextBox1.Value = ScrollBar1.Value
End Sub
Private Sub SpinButton1_SpinUp()
TextBox2 = DateAdd("d", -1, TextBox2.Value)
End Sub
Private Sub SpinButton1_SpinDown()
TextBox2 = DateAdd("d", 1, TextBox2.Value)
End Sub
Private Sub UserForm_Initialize()
Dim f As String
f = Dir(ThisWorkbook.path & "\pic\*.jpg")
Do
Me.ListBox1.AddItem f
f = Dir
Loop Until Len(f) = 0
TextBox2 = Date
End Sub
'**********图片控件****************
'图片控件中图片的导入
Private Sub ListBox1_Click()
Dim path
path = ThisWorkbook.path & "/pic/" & ListBox1.Value
Image1.Picture = LoadPicture(path) '用loadpicture函数加载图片
End Sub
'**********多页控件****************
'1 多页控件的多行是指什么？
'MultiRow 属性：当多页控件的标签很多时，可以分多行显示。
'2 多页控件的值
'1 选择第1个标签，Value为0，选择第2个Value为1....选择第N个Value为N-1
'2 设置值的属性后可以直接选取这个标签。如MultiPage1.Value=0 就可以选取第2个标签
Private Sub MultiPage1_Change()
' MsgBox MultiPage1.Value
End Sub
'3 隐藏标签
'Style 属性值为2时，可以隐藏标签
' Me.MultiPage1.Style = 2
向导的做法
Option Explicit
Private Sub MultiPage1_Change()
End Sub
Private Sub UserForm_Initialize()
Me.MultiPage1.Style = 2
Me.MultiPage1.Value = 0
按钮权限
End Sub
Sub 按钮权限()
Select Case Me.MultiPage1.Value
Case 0
上一步.Enabled = False
Me.Caption = "第1步 共" & Me.MultiPage1.Pages.Count & "步"
Case Me.MultiPage1.Pages.Count - 1
下一步.Enabled = False
Me.Caption = "第" & MultiPage1.Pages.Count & "步 共" & Me.MultiPage1.Pages.Count & "步"
Case Else
上一步.Enabled = True
下一步.Enabled = True
Me.Caption = "第" & MultiPage1.Value + 1 & "步 共" & Me.MultiPage1.Pages.Count & "步"
End Select
End Sub
Private Sub 上一步_Click()
Me.MultiPage1.Value = Me.MultiPage1.Value - 1
按钮权限
End Sub
Private Sub 下一步_Click()
Me.MultiPage1.Value = Me.MultiPage1.Value + 1
按钮权限
End Sub
第59、60集：Listview控件
mudle：
Option Explicit
Sub 父子转换法()
'On Error Resume Next
Dim 父亲(1 To 10000, 1 To 2) As String
Dim f, i, k, f2, f3, x, y, m
Dim arr1(1 To 100000) As String, q As Integer
Dim mynode As node, arr, d As New Dictionary
父亲(1, 1) = ThisWorkbook.path & "\2011年报表\"
父亲(1, 2) = "A1"
i = 1: k = 1
Do While i < UBound(父亲)
If 父亲(i, 1) = "" Then Exit Do
f = Dir(父亲(i, 1), vbDirectory)
Do
If InStr(f, ".") = 0 And f <> "" Then
m = m + 1
k = k + 1
父亲(k, 1) = 父亲(i, 1) & f & "\"
父亲(k, 2) = 父亲(i, 2) & Format(m, "00")
End If
f = Dir
Loop Until f = ""
i = i + 1
m = 0
Loop
'*******下面是提取各个文件夹的文件***
For x = 1 To k
If 父亲(x, 1) = "" Then Exit For
Debug.Print 父亲(x, 1)
f3 = Dir(父亲(x, 1) & "*.*")
Do While f3 <> ""
k = k + 1
m = m + 1
父亲(k, 1) = 父亲(x, 1) & f3 & "\"
父亲(k, 2) = 父亲(x, 2) & Format(m, "00")
' arr1(q, 2) = f3
f3 = Dir
Loop
m = 0
Next x
'
Range("b1").Resize(k, 2) = 父亲
End Sub
一、数据导入
Private Sub TreeView1_BeforeLabelEdit(Cancel As Integer)
End Sub
'treeview控件添加节点的ADD方法
'Treeview1.Nodes.Add(上一级节点的索引值,是否为子节点,节点的索引值,节点上显示的文字,图标的索引号,选取节点时的图标)
'一级节点的索引值和创建节点的位置为空。则表示创建是的顶级节点
Private Sub UserForm_Initialize()
Dim Nodx As node
TreeView1.ImageList = ImageList1 '从imagelist控件中提取图片
Set Nodx = TreeView1.Nodes.Add(, , "总公司", "总公司人事结构", 1) '总公司是顶级节点的索引值,
For x = 2 To Range("B65536").End(xlUp).Row
C1 = Cells(x, 1)
c2 = Cells(x, 2)
If Len(c2) = 1 Then '如果代码长度为1，说明是顶级节点下的二级节点
Set Nodx = TreeView1.Nodes.Add("总公司", tvwChild, "A" & c2, C1 & "(" & c2 & ")", 2)
'总公司：上一级节点的索引值
'tvwChild：子节点
' "A" & C2：C2是代码，连接A后作该节点的索引值，连接A的原因是索引不能为纯数字'
' C1 & "(" & C2 & ")" 是显示的内容，A列的内容+代码
' 2 是imagelist1控件中序号为2的图片
ElseIf Len(c2) = 3 Then '如果代码长度为3，说明是三级节点
Set Nodx = TreeView1.Nodes.Add("A" & Left(c2, 1), tvwChild, "A" & c2, C1 & "(" & c2 & ")", 3)
ElseIf Len(Cells(x, 2)) = 6 Then
Set Nodx = TreeView1.Nodes.Add("A" & Left(c2, 3), tvwChild, "A" & c2, C1 & "(" & c2 & ")", 4)
End If
Next
End Sub
二、数据读取
Private Sub TreeView1_Click()
Dim MyItem As node
Set MyItem = TreeView1.SelectedItem 'SelectedItem正在选取的节点
If Len(MyItem.Key) = 2 Then 'SelectedItem.Key 正在选取节点的索引值
TextBox1 = 截取名称(MyItem.Text) '如果是顶级节点,公司名称等于节点的显示内容(去掉代码)
TextBox2.Value = ""
TextBox3.Value = ""
TextBox4 = Replace(MyItem.Key, "A", "") '替换掉A后的代码
ElseIf Len(MyItem.Key) = 4 Then
TextBox1 = 截取名称(MyItem.Parent.Text) ' MyItem.Parent.Text上一级节点的显示文本
TextBox2 = 截取名称(MyItem.Text)
TextBox3.Value = ""
TextBox4 = Replace(MyItem.Key, "A", "")
ElseIf Len(MyItem.Key) = 7 Then
TextBox1 = 截取名称(MyItem.Parent.Parent.Text)
TextBox2 = 截取名称(MyItem.Parent.Text)
TextBox3 = 截取名称(MyItem.Text)
TextBox4 = Replace(MyItem.Key, "A", "")
End If
'TextBox1.Text = MyItem.Index
End Sub
Function 截取名称(AAA)
截取名称 = Left(AAA, InStr(1, AAA, "(") - 1)
End Function
Private Sub UserForm_Initialize()
Dim Nodx As node
TreeView1.ImageList = ImageList1
Set Nodx = TreeView1.Nodes.Add(, , "总公司", "总公司人事结构", 1)
For x = 2 To Range("B65536").End(xlUp).Row
C1 = Cells(x, 1)
c2 = Cells(x, 2)
If Len(Cells(x, 2)) = 1 Then
Set Nodx = TreeView1.Nodes.Add("总公司", tvwChild, "A" & c2, C1 & "(" & c2 & ")", 2)
ElseIf Len(Cells(x, 2)) = 3 Then
Set Nodx = TreeView1.Nodes.Add("A" & Left(c2, 1), tvwChild, "A" & c2, C1 & "(" & c2 & ")", 3)
ElseIf Len(Cells(x, 2)) = 6 Then
Set Nodx = TreeView1.Nodes.Add("A" & Left(c2, 3), tvwChild, "A" & c2, C1 & "(" & c2 & ")", 4)
End If
Next
End Sub
三、动态添加
Private Sub CommandButton1_Click()
Dim Nodx As node
'On Error GoTo 100
t1 = TextBox1.Value
t2 = TextBox2.Value
MCO = Range("A65536").End(xlUp).Row + 1
Cells(MCO, 1) = t2
Cells(MCO, 2) = t1
If Len(t1) = 1 Then
Set Nodx = TreeView1.Nodes.Add("总公司", tvwChild, "A" & t1, t2 & "(" & t1 & ")", 2)
'添加要确定添加的层次和上一级节点的索引值,这里用L
ElseIf Len(t1) = 3 Then
Set Nodx = TreeView1.Nodes.Add("A" & Left(t1, 1), tvwChild, "A" & t1, t2 & "(" & t1 & ")", 3)
'添加要确定添加的层次和上一级节点的索引值,这里用Left从代码中截取上一级的索引值,然后用来定位.
ElseIf Len(t1) = 6 Then
Set Nodx = TreeView1.Nodes.Add("A" & Left(t1, 3), tvwChild, "A" & t1, t2 & "(" & t1 & ")", 4)
End If
Nodx.EnsureVisible '自动展开节点
Exit Sub
100:
MsgBox "你设置的目录重复或上级目录不存在!"
Cells(MCO, 1) = ""
Cells(MCO, 2) = ""
End Sub
Private Sub UserForm_Initialize()
Dim Nodx As node
TreeView1.ImageList = ImageList1
Set Nodx = TreeView1.Nodes.Add(, , "总公司", "总公司人事结构", 1)
For x = 2 To Range("B65536").End(xlUp).Row
C1 = Cells(x, 1)
c2 = Cells(x, 2)
If Len(Cells(x, 2)) = 1 Then
Set Nodx = TreeView1.Nodes.Add("总公司", tvwChild, "A" & c2, C1 & "(" & c2 & ")", 2)
ElseIf Len(Cells(x, 2)) = 3 Then
Set Nodx = TreeView1.Nodes.Add("A" & Left(c2, 1), tvwChild, "A" & c2, C1 & "(" & c2 & ")", 3)
ElseIf Len(Cells(x, 2)) = 6 Then
Set Nodx = TreeView1.Nodes.Add("A" & Left(c2, 3), tvwChild, "A" & c2, C1 & "(" & c2 & ")", 4)
End If
Next
End Sub
四、动态修改
'**********修改代码*************
Private Sub CommandButton2_Click()
Dim Mnode As node
Dim MST As String
Dim dm
MST = Application.InputBox("请输入要修改的节点名称")
If Len(MST) = 0 Then Exit Sub
Set Mnode = TreeView1.SelectedItem
dm = Replace(Mnode.Key, "A", "") '提取代码
TreeView1.SelectedItem.Text = MST & "(" & dm & ")"
'TreeView1.SelectedItem.Text '直接设置当前选取节点的值
Cells(Columns(2).Find(dm, LookAt:=xlWhole).Row, 1) = MST
End Sub
Private Sub TreeView1_BeforeLabelEdit(Cancel As Integer)
End Sub
Private Sub UserForm_Initialize()
Dim Nodx As node
TreeView1.ImageList = ImageList1
Set Nodx = TreeView1.Nodes.Add(, , "总公司", "总公司人事结构", 1)
For x = 2 To Range("B65536").End(xlUp).Row
C1 = Cells(x, 1)
c2 = Cells(x, 2)
If Len(Cells(x, 2)) = 1 Then
Set Nodx = TreeView1.Nodes.Add("总公司", tvwChild, "A" & c2, C1 & "(" & c2 & ")", 2)
ElseIf Len(Cells(x, 2)) = 3 Then
Set Nodx = TreeView1.Nodes.Add("A" & Left(c2, 1), tvwChild, "A" & c2, C1 & "(" & c2 & ")", 3)
ElseIf Len(Cells(x, 2)) = 6 Then
Set Nodx = TreeView1.Nodes.Add("A" & Left(c2, 3), tvwChild, "A" & c2, C1 & "(" & c2 & ")", 4)
End If
Next
End Sub
五、动态删除
'**********修改代码*************
Private Sub CommandButton2_Click()
Dim Mnode As node
Dim MST As String
Dim dm
MST = Application.InputBox("请输入要修改的节点名称")
If Len(MST) = 0 Then Exit Sub
Set Mnode = TreeView1.SelectedItem
dm = Replace(Mnode.Key, "A", "") '提取代码
TreeView1.SelectedItem.Text = MST & "(" & dm & ")"
'TreeView1.SelectedItem.Text '直接设置当前选取节点的值
Cells(Columns(2).Find(dm, LookAt:=xlWhole).Row, 1) = MST
End Sub
Private Sub TreeView1_BeforeLabelEdit(Cancel As Integer)
End Sub
Private Sub UserForm_Initialize()
Dim Nodx As node
TreeView1.ImageList = ImageList1
Set Nodx = TreeView1.Nodes.Add(, , "总公司", "总公司人事结构", 1)
For x = 2 To Range("B65536").End(xlUp).Row
C1 = Cells(x, 1)
c2 = Cells(x, 2)
If Len(Cells(x, 2)) = 1 Then
Set Nodx = TreeView1.Nodes.Add("总公司", tvwChild, "A" & c2, C1 & "(" & c2 & ")", 2)
ElseIf Len(Cells(x, 2)) = 3 Then
Set Nodx = TreeView1.Nodes.Add("A" & Left(c2, 1), tvwChild, "A" & c2, C1 & "(" & c2 & ")", 3)
ElseIf Len(Cells(x, 2)) = 6 Then
Set Nodx = TreeView1.Nodes.Add("A" & Left(c2, 3), tvwChild, "A" & c2, C1 & "(" & c2 & ")", 4)
End If
Next
End Subs
第61集：日期和进度条
自动注册日期控件
Sub 自动注册日期控件()
Dim k
FileCopy ThisWorkbook.path & "/MSCOMCT2.OCX", "C:\Windows\system32\MSCOMCT3.OCX"
k = Shell("regsvr32 MSCOMCT2.OCX")
End Sub
日期控件
Private Sub CommandButton1_Click()
Range("a1") = Me.DTPicker1.Value
End Sub
Private Sub DTPicker1_CallbackKeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer, ByVal CallbackField As String, CallbackDate As Date)
End Sub
Private Sub UserForm_Initialize() '自定义格式
'DTPicker1.CustomFormat = "yyyy-MM-dd"
DTPicker1.Value = Date
End Sub
进度条
Private Sub CommandButton1_Click()
Dim x, w, k, n
w = TextBox1.Width
n = 4000
ProgressBar1.Max = n
ProgressBar1.Min = 0
ProgressBar1.Scrolling = ccScrollingSmooth
For x = 1 To n
k = k + w / n
ProgressBar1.Value = x
Label1.Width = k
Label2.Caption = Format(x / n, "0.00%")
DoEvents
Next x
End Sub
Private Sub UserForm_Initialize()
Label1.Width = 0
End Sub
进度条实例
Private Sub CommandButton1_Click()
Dim rg As Range, k As Long
Cells.Interior.ColorIndex = xlNone '清空单元格格式
ProgressBar1.Max = 70000 '设置进度条的最大值为5000行*14列
ProgressBar1.Min = 0
ProgressBar1.Scrolling = 1
For Each rg In Range("a1:n5000")
k = k + 1
If rg.Value < Val(TextBox1.Value) And rg.Value <> "" Then
rg.Interior.ColorIndex = 3
End If
ProgressBar1.Value = k
Next rg
MsgBox "设置完成"
End Sub
第62集：窗体综合实例
Option Explicit
'1 添加日期控件: 略
Private Sub MultiPage1_Change()
End Sub
'2 出库单号码设置
Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) '出库单号码强制输入，否则不允许离开
If TextBox2.Text = "" Then
Cancel = True '取消离开操作
End If
End Sub
Private Sub SpinButton1_SpinDown() '利用SpinDown事件和SpinUp事件改变出库单的号码
TextBox2.Text = Format(Val(TextBox2) + 1, "000") '点击向下的按钮出库单号码在原来的基础上加1
End Sub
Private Sub SpinButton1_SpinUp()
TextBox2.Text = Format(Val(TextBox2) - 1, "000") '点击向上的按钮出库单号码在原来的基础上减1
End Sub
'3 回车或点击按钮打开价格表窗口
Private Sub TextBox3_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If KeyCode = 13 Then
Me.MultiPage1.Value = 1
End If
End Sub
Private Sub CommandButton3_Click() '点击按钮打开单价窗口
Me.MultiPage1.Value = 1
End Sub
'4窗口加载表时完成treeview价格表导入和listview控件标题行生成
Private Sub UserForm_Initialize()
'Dim ITM As ListItem
ListView1.ColumnHeaders.Add 1, , "销售日期", ListView1.Width / 8 '设置第1列
ListView1.ColumnHeaders.Add 2, , "出库单号", ListView1.Width / 8, lvwColumnCenter '设置第2列
ListView1.ColumnHeaders.Add 3, , "商品代码", ListView1.Width / 8, lvwColumnCenter '设置第3列
ListView1.ColumnHeaders.Add 4, , "商品名称", ListView1.Width / 8, lvwColumnCenter '设置第4列
ListView1.ColumnHeaders.Add 5, , "型号", ListView1.Width / 8, lvwColumnCenter '设置第5列
ListView1.ColumnHeaders.Add 6, , "销售数量", ListView1.Width / 9, lvwColumnCenter '设置第6列
ListView1.ColumnHeaders.Add 7, , "销售单价", ListView1.Width / 8, lvwColumnCenter '设置第7列
ListView1.ColumnHeaders.Add 8, , "销售金额", ListView1.Width / 8, lvwColumnCenter '设置第8列
ListView1.View = lvwReport '设置为报告格式
ListView1.Gridlines = True '显示表格线
ListView1.FullRowSelect = True '可以选取整行
ListView1.MultiSelect = True
Call 添加Treeview数据
Me.MultiPage1.Value = 0 '显示输入界面
Me.MultiPage1.Style = 2 '隐藏选项卡
End Sub
Sub 添加Treeview数据()
Dim Nodx As Node
Dim arr, d As New Dictionary
Dim mykey, sr, x
TreeView1.ImageList = ImageList1 '从imagelist控件中提取图片
arr = Sheets("价格表").Range("a2:D" & Sheets("价格表").Range("a65535").End(xlUp).Row)
For x = 1 To UBound(arr)
mykey = arr(x, 1) & "," & arr(x, 2) & "," & arr(x, 3) & "," & arr(x, 4) '把商品所有信息连接起来,后面放在key里存放,以便随时调用
sr = arr(x, 3) & "(" & arr(x, 1) & ") 价格:" & arr(x, 4) '设置节点显示的内容
If Not d.Exists(arr(x, 2)) Then '如果该顶级节点不存在
d(arr(x, 2)) = "" '添加到字典里,以便下次判断是否存在
Set Nodx = TreeView1.Nodes.Add(, , arr(x, 2), arr(x, 2), 1, 1) '添加顶级节点
Set Nodx = TreeView1.Nodes.Add(arr(x, 2), tvwChild, mykey, sr, 2, 2) '添加子节点
Nodx.EnsureVisible '打开节点
Else
Set Nodx = TreeView1.Nodes.Add(arr(x, 2), tvwChild, mykey, sr, 2, 2) '添加子节点
End If
Next x
End Sub
'5 单击treeview或回车后,可以把选取的价格信息输入到相应的文本框中.然后焦点转到textbox5
Private Sub TreeView1_Click() '单击事件
TextBox3.Text = Split(Me.TreeView1.SelectedItem.Key, ",")(0) '从key取出值折分开分别放在四个文本框内
TextBox4.Text = Split(Me.TreeView1.SelectedItem.Key, ",")(1)
TextBox8.Text = Split(Me.TreeView1.SelectedItem.Key, ",")(2)
TextBox6.Text = Split(Me.TreeView1.SelectedItem.Key, ",")(3)
Me.MultiPage1.Value = 0
TextBox5.SetFocus
End Sub
Private Sub TreeView1_KeyDown(KeyCode As Integer, ByVal Shift As Integer) '按钮事件
If KeyCode = 13 Then
TextBox3.Text = Split(Me.TreeView1.SelectedItem.Key, ",")(0) '从key取出值折分开分别放在四个文本框内
TextBox4.Text = Split(Me.TreeView1.SelectedItem.Key, ",")(1)
TextBox8.Text = Split(Me.TreeView1.SelectedItem.Key, ",")(2)
TextBox6.Text = Split(Me.TreeView1.SelectedItem.Key, ",")(3)
Me.MultiPage1.Value = 0
TextBox5.SetFocus
End If
End Sub
'6 输入数量时自动计算金额,和输入后按回车添加到listview控件中
Private Sub TextBox5_Change()
TextBox7.Value = Val(TextBox5) * Val(TextBox6.Value) '输入数量时自动计算金额
End Sub
Private Sub TextBox5_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim lv As ListItem
If KeyCode = 13 And TextBox5 <> "" Then
'向listview中框添加记录
With ListView1
Set lv = .ListItems.Add
lv.Text = DTPicker1.Value
lv.SubItems(1) = TextBox2.Text
lv.SubItems(2) = TextBox3.Text
lv.SubItems(3) = TextBox4.Text
lv.SubItems(4) = TextBox8.Text
lv.SubItems(5) = TextBox5.Text
lv.SubItems(6) = TextBox6.Text
lv.SubItems(7) = TextBox7.Text
TextBox5 = ""
TextBox3 = ""
TextBox3.SetFocus
End With
End If
End Sub
'7 清空listview和删除选取的行
Private Sub ListView1_DblClick() '为listview控件增加清空所有行的功能
If MsgBox("你要清空所有行吗", vbOKCancel) = vbOK Then
ListView1.ListItems.Clear '用ListItems对象的clear方法可以清空所有行
End If
End Sub
Private Sub ListView1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As stdole.OLE_XPOS_PIXELS, ByVal y As stdole.OLE_YPOS_PIXELS)
If Button = 2 Then
If MsgBox("你要删除选取的行吗", vbOKCancel) = vbOK Then
ListView1.ListItems.Remove ListView1.SelectedItem.Index '用ListItems对象的clear方法可以清空所有行
End If
End If
End Sub
'8 把listview中的所有数据添加到出库表中.
Private Sub CommandButton1_Click() '把listview列表中的数据输出到工作表中
Dim arr()
Dim icount As Integer, y As Integer, x
icount = ListView1.ListItems.Count 'ListItems.Count 返回总行数
ReDim arr(1 To icount, 1 To 8)
For x = 1 To icount
arr(x, 1) = ListView1.ListItems(x).Text '把listview第1列(text）放在数组第一列
For y = 1 To 7
arr(x, y + 1) = ListView1.ListItems(x).SubItems(y)
Next y
Next x
Range("a65536").End(xlUp).Offset(1, 0).Resize(icount, 8) = arr
Me.ListView1.ListItems.Clear
TextBox2.Text = Format(Val(TextBox2) + 1, "000")
TextBox3.SetFocus
TextBox3 = ""
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
第63集：命令栏操作之命令栏
一_命令栏对象结构
Option Explicit
' Excel里所有命令栏的集合：CommandBars
'一、表示方法
' 1 CommandBars(index)可以按序号表示excel中命令栏
' 2 CommandBars(命令栏名称) 也可以表示某一个命令栏
'二 命令栏中的命令集合Controls
' 1 CommandBars(index).Controls(index)可以按序号表示菜单中的某个命令
' 2 CommandBars(index).Controls(命令标题) 也可以表示某一个命令
'三 子菜单中的命令表示方法 CommandBars(index).Controls(命令).Controls(命令)
二_Excel命令栏操作
Option Explicit
'1 Excel有哪些命令栏
Sub 列出所有命令栏()
Dim x As Integer
For x = 1 To Application.CommandBars.Count
With Application.CommandBars(x)
Cells(x + 1, 1) = x
Cells(x + 1, 2) = .Name '英文名
Cells(x + 1, 3) = .NameLocal '本地化名称
Cells(x + 1, 4) = .Type
'msoBarTypeMenuBar 菜单类型
'msoBarTypeNormal 普通工具栏格式
'msoBarTypePopup 弹出式菜单
Cells(x + 1, 5) = .BuiltIn '是否为内置工具栏
End With
Next x
End Sub
'2 修改Excel的命令栏
'命令栏的enabled属性可以屏蔽命令栏
Sub 操作命令栏()
Application.CommandBars("cell").Enabled = True '屏蔽单元格右键菜单
'Application.CommandBars(35).Enabled = false '屏蔽工作表标签右键菜单
'Application.CommandBars(1).Enabled = False '屏蔽工作表菜单
End Sub
'3 添加新的命令栏
'.Add(Name, Position, MenuBar, Temporary)
'Name:命令栏的名称
'Position：命令栏显示的位置
'msoBarLeft、msoBarTop、msoBarRight 和 msoBarBottom 指定新命令栏的左侧、顶部、右侧和底部坐标
'msoBarFloating 指定新命令栏不固定,漂在工作表上
'msoBarPopup 指定新命令栏为快捷菜单
'msoBarMenuBar 仅适用于 Macintosh 机
'MenuBar：会用添加的命令栏替换活动菜单栏
'Temporary ：是否为临时命令栏（Excel关闭后是否会自动删除)
Sub 添加命令栏()
Dim myBAR As CommandBar
Set myBAR = Application.CommandBars.Add("我的命令栏", msoBarLeft, False, True)
myBAR.Visible = True '添加后要显示出来才能看到
End Sub
'4 删除命令栏
'删除命令栏直接用delete方法
Sub 删除命令栏()
Dim myBAR As CommandBar
Set myBAR = Application.CommandBars("我的命令栏")
myBAR.Delete
End Sub
'5 恢复命令栏的默认设置
Sub 恢复命令栏默认()
Dim myBAR As CommandBar
Set myBAR = CommandBars("我的命令栏")
myBAR.Reset
End Sub
三_Excel内置命令操作
'1 命令的表示方法
Sub cc1() '屏蔽编辑菜单
Application.CommandBars(1).Controls("编辑(&E)").Enabled = False
End Sub
Sub cc2() '解除屏蔽
Application.CommandBars(1).Controls("编辑(&E)").Enabled = True
End Sub
Sub cc3() '屏蔽控件的子控件
Application.CommandBars(1).Controls("编辑(&E)").Controls("复制(&C)").Enabled = False
End Sub
'命令的查找
Sub cc4() '屏蔽所有命令栏中复制命令
Dim combars As CommandBarControls
Dim combar As CommandBarControl
Dim k As Integer, idnum As Integer
idnum = Application.CommandBars(1).Controls("编辑(&E)").Controls("复制(&C)").ID
Set combars = Application.CommandBars.FindControls(ID:=idnum)
For Each combar In combars
combar.Enabled = False
Next combar
End Sub
四_添加自定义命令
Option Explicit
'在指定的命令栏中添加命令
Dim mycom As CommandBarComboBox
Sub tiancom()
On Error Resume Next
Dim myBAR As CommandBarButton
Application.CommandBars("CELL").Controls("我的命令").Delete
Set myBAR = Application.CommandBars("cell").Controls.Add(before:=1) '添加到最上的位置
With myBAR
.Caption = "我的命令"
.BeginGroup = True '添加分组线
.FaceId = 199 '显示的图标
.Style = msoButtonIconAndCaption '图标和文字的显示
.OnAction = "ABC" '指定要运行的宏
End With
End Sub
Sub 添加组合框()
On Error Resume Next
Dim x
Application.CommandBars("CELL").Controls("工作表显示").Delete
Set mycom = Application.CommandBars("cell").Controls.Add(Type:=msoControlComboBox, before:=1) '添加到最上的位置
With mycom
.Caption = "工作表显示"
.BeginGroup = True '添加分组线
'.FaceId = 199 '显示的图标
'.Style = msoButtonIconAndCaption '图标和文字的显示
.OnAction = "选取工作表" '指定要运行的宏
.Width = 100
.DropDownWidth = 70
For x = 1 To Sheets.Count
.AddItem Sheets(x).Name
Next x
End With
End Sub
Sub 添加子菜单()
On Error Resume Next
Dim x, copup As CommandBarPopup, copup1 As CommandBarButton, copup2 As CommandBarPopup
Application.CommandBars("CELL").Controls("工作表显示").Delete
Set copup = Application.CommandBars("cell").Controls.Add(Type:=msoControlPopup, before:=1) '添加到最上的位置
With copup
.Caption = "工作表显示"
.BeginGroup = True '添加分组线
End With
Set copup1 = copup.Controls.Add(before:=1) '添加到最上的位置
With copup1
.Caption = "复制工作表"
.FaceId = 22
.Style = msoButtonIconAndCaption '图标和文字的显示
End With
Set copup1 = copup.Controls.Add(before:=2) '添加到最上的位置
With copup1
.Caption = "删除工作表"
.FaceId = 20
.Style = msoButtonIconAndCaption '图标和文字的显示
End With
Set copup2 = copup.Controls.Add(Type:=msoControlPopup, before:=3) '添加到最上的位置
With copup2
.Caption = "移动工作表"
End With
End Sub
Sub ABC()
MsgBox "这是运行的宏"
End Sub
Sub 删除命令()
On Error Resume Next
With Application.CommandBars("CELL").Controls(1)
If .BuiltIn = False Then .Delete
End With
End Sub
Sub 选取工作表()
Sheets(mycom.Text).Select
End Sub
五_添加快捷键菜单示例
Option Explicit
Sub 添加快捷菜单()
Dim mypup As CommandBar
Dim com As CommandBarButton
Dim x
删除命令
Set mypup = Application.CommandBars.Add(Name:="ABC", Position:=msoBarPopup)
For x = 1 To 4
Set com = mypup.Controls.Add
com.Caption = Choose(x, "兰色幻想", "小妖", "小佩", "展翅")
com.FaceId = 17 + x
com.OnAction = "A"
Next x
End Sub
Sub 删除命令()
Application.CommandBars("ABC").Delete
End Sub
Sub A()
UserForm1.TextBox1 = 100
End Sub
264
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
