编程常用代码
Excel2007启用宏：OFFICE按钮→选项→信任中心→信任中心设置→宏设置
代码里可以命名名称，比如https://www.doczj.com/doc/ed10823983.html, = "data1" ，然后在公式中使用它
Debug.Print "7777" '在立即窗口中显示
Environ("Computername") '计算机名
Environ("userprofile")‘桌面路径
ActiveWindow.Caption="XXXXX" '在显示文件名的地方显示XXXXX
Windows(https://www.doczj.com/doc/ed10823983.html,).Visible = False '隐藏excel主窗口https://www.doczj.com/doc/ed10823983.html,[文件名]
在word中读取excel中数据
Set sht = GetObject(, "excel.application").ActiveSheet '假设要获取的内容为已经打开的excel文档的活动工作表
k = sht.Cells(2, 3) '假设要获取第1行第2列的单元格,亦可用range("b1")代替cells(1,2)
-------
文件和文件夹
当前文件夹的名称：CurDir
更改文件或文件夹的名称：（Name 原文件As 新文件）
检查文件或文件夹是否存在：m=Dir(文件,Nomal) m=Dir(文件夹,Folder)Directory
创建文件夹（MkDir "D：\文件夹名"）
f = Dir("D:\省份分表", vbDirectory) '判断是否已经存在
If f = "" Then MkDir ("D:\省份分表") '如果不存在就建立
删除文件：（Kill "D：\文件夹名\成品.xls"
删除空文夹：（RmDir "D：\文件夹名"）
---------
复制文件：（FileCopy）
For i = 101 To 10000
FileCopy "D:\迅雷.txt", "D:\文件夹名\" & i & "迅雷.txt"
Next
With Application.FileSearch
.Filename = "*.*"
.LookIn = ThisWorkbook.Path & "\分表"
.Execute
k = .FoundFiles.Count '文件夹中的文件个数
End With
Sub 生成目录() '有子文件夹也查到
Set fs = Application.FileSearch
With fs
.LookIn = "D:\暂用\" '设置要查找的起始目录
.Filename = "*.*"
.SearchSubFolders = True '是否查找子目录
.Execute '根据上面的设置执行查找
For i = 1 To .FoundFiles.Count '遍历文件
a = Dir(.FoundFiles(i))
Cells(i + 1, 3) = a
Next i
End With
End Sub
Shell "explorer.exe " & k & "\生成的表\", vbMaximizedFocus'展开文件夹
Sub动态读取指定文件夹名()
On Error Resume Next
Dim stMedd As String
stMedd = "请选择文件目录："
Set obMapp = CreateObject("Shell.Application").BrowseForFolder(0, stMedd, &H1)
If Not obMapp Is Nothing Then
Directory = obMapp.self.Path & "\" '文件夹名
[G1].Value = Directory
Else
Exit Sub
End If
Call FilesList.FilesList
End Sub
If VBA.Dir("D:\S.xls") = "" Then MsgBox "文件没有找到" ‘判断文件不存
Sub 删除指定区间的图片()
For Each drt In ActiveSheet.DrawingObjects
If Not Intersect(drt.TopLeftCell, [C3:L16]) Is Nothing Then drt.Delete
Next
End Sub
变量
模块级变量的声明格式Public Directory
Dim x As Integer '声明变量
Byte (0到255的整数) Integer % (-32768+32768) Date (日期) String $ (65400个字符) Decimal (小数) Long & Single ! Currency @
Format(32, "0000")‘Format格式结果为：0032
数组
Dim Arr()
ReDim Preserve Arr(1 To r) ‘声明动态数组
Array函数Application.Transpose ‘转置
数组下限LBound(Arr)=0 ，数组上限UBound(Arr)=4
Erase arr ’清空数组
IsArray ’指出变量是否为一个数组
If Application.CountA(Arr)>0 Then '判断数组不为空
Range("A1:D1") = Array("'1001", "现金", 300000, Date) '在一行多列中依次输入不同数据
Range("A1:A4") = Application.Transpose(Array("1001", "现金", 300000, Date))在一列多行中次输入不同数Sub 字典()
r = Sheet1.Range("A65536").End(xlUp).Row '行数
Set w = CreateObject("scripting.dictionary")
For i = 2 To r
b = Sheet1.Cells(i, 2)
c = Sheet1.Cells(i, 3)
If Not w.exists(b & c) Then
w(b & c) = 1
Else
W(b & c) = W(b & c) + 1
End If
Next
[A2].Resize(w.Count, 1) = Application.Transpose(w.keys)
[B2].Resize(w.Count, 1) = Application.Transpose(w.items)
End Sub
Sub 用字典筛选多列()
r = Range("A65536").End(xlUp).Row '最后行数
Set w = CreateObject("scripting.dictionary")
For i = 2 To r
If Cells(i, 6) > 70 Then '语文分数为条件
w(Range(Cells(i, 1), Cells(i, 12))) = 1 '数据一行多列载入字典
End If
Next i
[N2].Resize(w.Count, 12) = Application.Transpose(Application.Transpose(w.keys)) '两次转置写入单元格
End Sub
Sub 字符串分列() '网页数据
For h = 2 To 44
m = Split(Cells(h, 1), " ") '以空格分开
k = UBound(m) + 1 '分出的列数
Cells(h, 13).Resize(1, k) = m
Next
End Sub
If "dfg"Like "*f*" Then判断字符串包含关系可用通配符
For Each st In Worksheets
With Chr(10) Exit For step 步长ElseIf Else Do While … Loop
Application.ScreenUpdating = False '禁用刷新
Application.DisplayStatusBar = False '禁用状态显示
Application.Calculation = xlCalculationManual '手动重算
Application.EnableEvents = False '禁用触发事件
ActiveSheet.DisplayPageBreaks = False '禁用新版本
Application.ScreenUpdating = true '启用刷新
Application.DisplayStatusBar = true'显示状态
Application.EnableEvents = true '启用触发事件
Application.Calculation = xlAutomatic '自动重算
ActiveSheet.DisplayPageBreaks = true '启用新版本
Application.SheetsInNewWorkbook = 1'设置工作簿内的工作表数
Application.SendKeys "%{down}" '自动打开数据有效性列表
Workbooks("学习.xls").Worksheets("Sheet1").Range("A4").ClearContents '从文件到单元格
Cells(4, 1) Rang("A4") [A4] '单元格
Range("H3").Select '选定单元格
Range("A65536").End(xlUp) '最后行单元数据
x=Range("A65536").End(xlUp).Row '行数
x = Range("e2").End(xlDown).Row ''向下查找
Range("IV1").End(xlToLeft) '最后列单元数据
Range("IV1").End(xlToLeft).Column '列数
UsedRange.Cells工作表使用区域的单元格
a = https://www.doczj.com/doc/ed10823983.html,edRange.Item(https://www.doczj.com/doc/ed10823983.html,edRange.Count).Row '格式最后行
b = https://www.doczj.com/doc/ed10823983.html,edRange.Item(https://www.doczj.com/doc/ed10823983.html,edRange.Count).Column '格式最后列
Cells(a, b) '最后一个单元格（不一定有数据）
(Cells(1, 1), Cells(a, b)) '数据最大区间起于A1单元格，止于最右下角单元格
f=Replace(mid(Cells(100,103).Address,2,2),"$","") ' 由列数得到列标CY
Cells.Find("*", , , , , 2).Row ' 工作表使用的有数据行数
Cells.Find("*", , , , , 2) .Column ' 工作表使用的有数据列数
IsNumeric判断数值
https://www.doczj.com/doc/ed10823983.html,edRange.Select '选定表1中使用的区域，如果要向下或右移在UsedRange.后加进offset(1,2) Range("a1").Copy Range("B1") '将A1单元数值（公式）和格式值复制到sheet3 B1中
注：Range("a1")不能用Cells()替代
Range("B1").Value = Range("a1").Value '将A1单元数值复制到sheet3 B1中
Range("C4:E7").Clear '清除格式和内容
Range("D4:E6").ClearContents '清除内容
ActiveWindow.VisibleRange.AddressLocal ' 返回屏幕上可以看到的区域
[a3].Value = Trim([a3].Value) '删除空格删左边Ltrim 删右边RTrim
[a:a].Replace "A", "" '将A列的“A”替换成空单元格匹配LookAt:=xlWhole
Application.SUBSTITUTE([A1]," ","") ‘清除空格
显示指定单元格
ActiveWindow.SmallScroll Down:=-65536 '向下滚动在最高处显示第1行
ActiveWindow.SmallScroll ToRight:=-255 '先向右移在最左边显示第1列
ActiveWindow.SmallScroll Down:=30 - 1 '再向上滚动在最处显示第30行
ActiveWindow.SmallScroll ToRight:=10 - 1 '再向左移在最左边显示第10列
Range("B2").Offset(1, 2).Select '以B2为基点，向下移1行，向右移2列
Selection.Resize(6, 9).Select '得到一个6行9列的区域
Range("B3:B" & k.Count + 2).TextToColumns , Other:=True, OtherChar:="/" ‘分列
[a:b].AdvancedFilter 2, [c1:c2], [g1] '高级筛选最简代码数据区间[a:b] 条件[c1:c2] 存放位置[g1]
Sheet1.[a:a].AdvancedFilter 2, "", [b5], Unique:=True 'Unique:=True (取不重复值)
[A1:D11].AdvancedFilter 2, , [E1], 1 '高级筛提取不重复值数据区间[A1:D11] 存放位置[E1]
MsgBox "行数为：" & ActiveCell.Row & Chr(10) & "列数为：" & ActiveCell.Column'当前行列数
Chr(10)：空行
公式
Range("A1").NumberFormat '读出A1格式
Range("A1").Formula '读出A1中的公式
Range("D2").FormulaArray = "=SUM((A2:A6)*1）" '先在D2中输入数组公式
Range("D2").Copy Range("D3:D9,E2:E9,F2:F9") '复制、粘贴公式（区间连续或不连续，但不能包括D2）Selection.Formula = Range("e2").Formula '将E2中的普通公式填充到当前区域
For m = 2 To y '宏中动态引用公式（不适用于数组公式）
Range("m" & m) = Evaluate("SUMPRODUCT((sheet1!A2:A" & x & "=sheet2!A" & m & ")*(sheet1!B2:B" & x & "=sheet2!B" & m & ")*(sheet1!L2:L" & x & ">sheet2!L" & m & "))") + 1
Find方法的语法
<单元格区域>.Find (要查找的数据，，[数据类型]，[XlWhole或者xlPart，用来指定所查找的数据是与单元格内容完全匹配还是部分匹配，默认值为xlPart])
Sub 由值查行列号() ‘Find方法
Set r = Range("a1:b12").Find([j6],,, XlWhole) ‘对占用内存较多的对象变量，不要时要记住set=nothing
On Error Resume Next ‘容错r = Empty（出错）
[K6] = r.Row '行号
[L6] = r.Column '列号
[m6] = r.Address '单元格
Set r=nothing‘置空对象
End Sub
Sub 数组查找()
Dim Arr()
x = Sheet1.Range("A65536").End(xlUp).Row '行数
y = Range("A65536").End(xlUp).Row '行数
ReDim Preserve Arr(1 To y)
For i = 1 To y
On Error Resume Next '容错
b = Cells(i, 1)
Set r = Sheet1.Range("a1:a" & x).Find(b, , , xlWhole)
If r = Empty Then 'Empty（出错）
Arr(i) = ""
Else
Arr(i) = Sheet1.Cells(r.Row, 2)
End If
Next
[B1].Resize(y, 1) = Application.Transpose(Arr)
End Sub
MATCH函数方法用于取得关键字的行数或列数
If IsNumeric(Application.Match(Cells(i, 1), .Range("B1:B" & r), 0)) Then
' 关键字不存在时会出错，上句不可少
m = Application.Match(Cells(i, 1), .Range("B1:B" & r), 0) ' 行数
Sub 查找()
Application.ScreenUpdating = False '禁用刷新
With Sheets("资料表")
x = .Range("R65536").End(xlUp).Row
y = Range("F65536").End(xlUp).Row
For i = 2 To y
If IsNumeric(Application.Match(Cells(i, 6), .Range("R1:R" & x), 0)) Then
m = Application.Match(Cells(i, 6), .Range("R1:R" & x), 0) ' 行数
.Range("N" & m & ":Q" & m).Copy Cells(i, 1)
End If
Next
End With
End Sub
x = [a1] '多条件语句
If x < 100 And x > 80 Then '第1句
[d5] = "好"
ElseIf x = 0 Then '第2句
[d5] = "最好"
Else '其他
[d5] = "错误"
End If
Select Case Sheets.Count '按条件选择执行宏
Case Is > 1
删除工作表
插入新表
Case Is = 1
插入新表
Case Else
End Select
End Sub
ThisWorkbook.Path (或CurDir) '当前工作簿地址
https://www.doczj.com/doc/ed10823983.html, 当前工作簿名称
ThisWorkbook.FullName '当前工作簿路径和名称
https://www.doczj.com/doc/ed10823983.html, '当前工作表名
Sheet1.ScrollArea = "B4:H12" '限制表中显示的区间
Private Sub Workbook_Open() '打开工作簿时执行
ActiveWindow.Close Savechanges:=True '不保存关闭当前工作簿
Private Sub Workbook_BeforeClose(Cancel As Boolean) '关闭工作簿时执行Application.Quit'不保存退出
Workbooks(1).Close SaveChanges:=False ‘不保存关闭指定工作簿ActiveWorkbook.Save '保存退出
Workbooks.Open Filename:=ThisWorkbook.Path & "\档案.xls", Password:="1234" '如文件：档案，有密码1234 用这句代码可以打开excel 模板文件类型：xlt
打开另一程序
m = Shell("C:\Documents and Settings\Administrator\桌面\kk.exe", 1)
AppActivate m
For Each c In https://www.doczj.com/doc/ed10823983.html,s '隐藏[显示]定义名
c.Visible = False
Next c
MsgBox "宏" & Chr(13) & Chr(13) & "真难学啊！", , "感叹"'消息框格式Chr(13) 换行
InputBox函数：格式如下，第一项为必须外，其余为可选项,可以省略不写，XY坐标为在窗体上的准确位置。当用户点取消时，返回一个空的字符串(" ")。为了省略某些位置参数，必须加入相应的逗号分界符。InputBox("对话框中的提示信息","对话框的标题","缺省的返回值"，X坐标，Y坐标)
X坐标和Y坐标当你需要为InputBox窗口指定在屏幕中的位置时用的，单位为象素，一般省略不写。Val文本变数值
Sub 选定单元格() ‘InputBox方法Application.Interactive = True
Dim a As Range
On Error GoTo VeryEnd'[当按下“取消”按钮时，程序会出错，加上此句与后边VeryEnd:相对应，这样当出错时，程序结束或Application.Interactive = True]
Set a = Application.InputBox(prompt:="使用鼠标选择单元格区域：", Title:="格式化区域", Type:=8)
a.NumberFormat = "0.00" '单元格式：两位数
VeryEnd:
End Sub
Sub 合并单元格()
Application.DisplayAlerts = False '合并时不提问
For h = Range("A65536").End(xlUp).Row To 4 Step -1
If Cells(h, 10) = Cells(h + 1, 10) Then Range(Cells(h, 10), Cells(h + 1, 10)).Merge
Next
End Sub
Range("B4:D5").Select '合并居中
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ReadingOrder = xlContext
End With
Selection.Merge' (合并单元格)
――――
[a1:g18].Borders.LineStyle = 1 '加细边框
Range("A6:F10").Borders.LineStyle = xlContinuous '加细边框
Range("A6:F10").BorderAround Weight:=xlThick '加边粗框
Range("A6:F10").Borders.LineStyle = xlNone '去边框
――――
With [J3:K257]
.HorizontalAlignment = xlCenter '居中
.VerticalAlignment = xlCenter '居中
End With
Sub 循环() ‘Exit For 跳出循环end
x = Range("A65536").End(xlUp).Row '声明最后一行的行号
For h = 5 To x '从第1行到最后一行step 步长
If Cells(h, 1) > 0 Then '判断、赋值
Cells(h, 2) = "大于零"
ElseIf Cells(h, 1) = 0 Then
Cells(h, 2) = "等于零"
ElseIf Cells(h, 1) < 0 Then
Cells(h, 2) = "小于零"
End If
Next h
End Sub
Sub行列多循环()
a = [p2] - 1
For b = 1 To 11 Step 2
For c = 4 To 28
a = a + 1'此句决定其数据不同
If a > [p3]Then Exit Sub '此句在达到最大值时退出循环
Cells(c, b) = a
Next c, b
End Sub
Private Sub Worksheet_Change(ByVal Target As Range) '单元格触发事件[输入即保存] If Target <> "" Then '没有选定或输入字符不触发
ActiveWorkbook.Save '保存
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range) '鼠标选定触发Cells.Interior.ColorIndex = 0 '整个工作表无色
Target.Interior.ColorIndex = 35 '鼠标选定区域变色
End Sub
sheets("数据").Visible=xlSheetVeryHidden ‘隐藏工作表
sheets("数据").Visible=xlSheetVisible ‘显示工作表
https://www.doczj.com/doc/ed10823983.html, = "数据" '插入名为数据的工作表
Sub 删除工作表() '只保留最左边那一个
Dim mysheet As Worksheet
If Worksheets.Count > 1 Then '有2个以上才删除
Worksheets(2).Select
Application.DisplayAlerts = False '删除表时不提问
For Each mysheet In Worksheets
ActiveWindow.SelectedSheets.Delete
Next mysheet
End If
End Sub
Sub 工作表合并() '当前表、目录表和统计表不合并，其他表都合并
For Each st In Worksheets
If https://www.doczj.com/doc/ed10823983.html, <> https://www.doczj.com/doc/ed10823983.html, And https://www.doczj.com/doc/ed10823983.html, <> "目录" And https://www.doczj.com/doc/ed10823983.html, <> "统计" Then
https://www.doczj.com/doc/ed10823983.html,edRange.Offset(2, 0).Copy [a65536].End(xlUp).Offset(1, 0)
End If
Next
End Sub
Sub生成目录()
Dim myPath As String
Dim myFileName As String
Dim i As Long
myPath = ThisWorkbook.Path & "\" '指定文件夹
myFileName = Dir(myPath, 0)
i = 0
Do While Len(myFileName) > 0
Cells(i + 1, 1) = Left(myFileName, Len(myFileName) - 4) '生成目录
myFileName = Dir()
i = i + 1
Loop
End Sub
Sub批量修改文件名()
aaa = ThisWorkbook.Path
h = 2
Do
oldname = Cells(h, 2)
newname = Cells(h, 1)
If oldname = Empty Then Exit Do
On Error Resume Next ‘出错时继续下一步m=Err.Number[错误号数,m=0,无错]
Name aaa & "\" & oldname & ".xls" As aaa & "\" & newname & ".xls" '实际用时就改一下文件后辍名On Error GoTo 0
h = h + 1
Loop
End Sub
Sub 删除工作簿()
On Error Resume Next
Kill "D:\123\111.xls "
End Sub
Sub 列出工作表名() '用到循环
For k = 1 To Sheets.Count '工作表总数Sheets.Count
Cells(k, 1) = Sheets(k).Name '工作表名存放位置Cells(k, 1) 第K个工作表名Sheets(k).Name Next
End Sub
Sub 删除所有定义名称()
Dim n As Name
For Each n In https://www.doczj.com/doc/ed10823983.html,s
n.Delete
Next
MsgBox "所有名称已被删除！"
End Sub
Sub 计算运行时间()
Dim Start As Double, Finish As Double
Start = Timer '开始时间
'--------------------------------------
Worksheets(1).Range("H1:H40000").Replace "4", "4.5"'过程
'--------------------------------------
Finish = Timer '结束时间
MsgBox "本次运行的时间是：" & Finish - Start & "秒"
End Sub
Sub 导入表2并填色()
Sheets(1).Rows("13:22").Copy Sheets(2).Rows("2:11") '表1复制到表2（全部）
Sheets(2).Rows("2:11")https://www.doczj.com/doc/ed10823983.html, = "黑体" '将这个范围字体格式为“黑体”
Sheet(2).Range("a3").Interior.ColorIndex = 6 '在A3单元中填进黄色
End Sub
Sub 判断工作表是否存在()
Dim sh As Worksheet
Dim d$
d = Day([r5]) & "日" '新表名来源
For Each sh In Worksheets
If https://www.doczj.com/doc/ed10823983.html, = d Then n = n + 1
Next
If n = 0 Then '不存在
Worksheets.Add after:=Sheets(Sheets.Count) '在所有表最右边插入一表
https://www.doczj.com/doc/ed10823983.html, = d '新表名为d
ElseIf n > 0 Then '表存在
[m26] = "SSSSS" '在M26中输入字母
End If
End Sub
Sub判断工作表是否存在()
r = InputBox("", "")
For h = 1 To Sheets.Count
If r = Sheets(h).Name Then
MsgBox r & "存在"
End
End If
Next
MsgBox r & "不存在"
End Sub
Sub汇总()
Application.ScreenUpdating = False
x = Sheet1.Range("A65536").End(xlUp).Row '最后行数A VG 算术平均数
With CreateObject("adodb.connection")
.Open "provider=microsoft.jet.oledb.4.0;extended properties='Excel 8.0;hdr=no;';data source=" & ThisWorkbook.FullName
[p4].CopyFromRecordset .Execute("select f1 from[sheet1$a3:n" & x & "] group by f1")
.Close
End With
Application.ScreenUpdating = true
End Sub ‘数据库无标题：hdr=no数据库有标题：hdr=yes
'条件取不重复值where f4>=3 group by f5
Sub 更改透视表字段为求和()
For h = 2 To 21
m = Cells(4, h).Value
Cells(4, h).Select
ActiveSheet.PivotTables("数据透视表1").PivotFields(m).Function = xlSum
Next
End Sub
Sub 错误处理()
Dim I As Long
On Error Resume Next' 指定发生错误时不处理，直接运行下一条语句
I = "A1" ' 发生错误,由于已经指定了发生错误时不处理，故Err对象立即返回直接运行下一条语句。
Debug.Print "被忽略的错误,错误代码：" & Err.Number & " 错误信息" & Err.Description & " 错误源：" & Err.Source & " 当前I的值=" & I
Err.Clear ' 清空所有错误记录
On Error GoTo ERROR1 ' 指定下面的错误发生时直接跳转至Error1标号处
I = 2147483648# ' 发生错误,由于指定了跳转，故直接转至Error1，而不会再执行下面的语句
I = 100
Debug.Print "程序正常返回，当前I的值=" & I
Exit Sub
ERROR1:
Debug.Print "发生错误,错误代码：" & Err.Number & " 错误信息" & Err.Description & " 错误源：" & Err.Source & " 当前I的值=" & I
End Sub
Sub 调出窗体()
UserForm1.Show 0
End Sub
LoadPicture函数返回图片对象Image1.Picture = LoadPicture("E:\图片\6.jpg")
Image1.Picture = Nothing '清空图片
Private Sub UserForm_Initialize() '初始化装入工作表名
Set d = CreateObject("scripting.dictionary")
For i = 1 To Worksheets.Count
d(Sheets(i).Name) = 1
Next
ComboBox7.List = d.keys
End Sub
AppActivate Application.Caption '焦点移到工作表
TextBox2.SetFocus‘用户窗体控件的激活
TextBox1.Activate‘工作表控件的激活
Application.SendKeys "{HOME}" 窗体滚动条停于上边缘
For s = 1 To 16
Controls("TextBox" & s).Value = "" ‘控件循环清空
Next
IsDate(m)= True 判断日期
'点×无效
Private Sub CommandButton1_Click()
Unload Me
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub
'点×无效
Unload UserForm1'窗体退出
Application.Visible = True '在窗体退出后，显示excel主窗口条形码控件BarCodeCtrl1
Private Sub CommandButton1_Click() ‘进度条
For t = 1 To 60000
ProgressBar1.Value = t / 100
DoEvents '此句作用：1、点按钮2可终止循环2、Label1.Caption可实时显示Label1.Caption = "程序运行了" & t / 600 * 100 & "%"
Next
End Sub
LEFT(1.369,InStr(1.369,".")+2) ’截取指定位数的数字
s = Format(Date, "[DBNum1][$-804]yyyy""年""m""月""d""日"" aaaa;@") MsgBox "今天是" & s
年Year(Date) 月Month(Date) 日Day(Date) 日期DateSerial(2010, 4,1) 第n月天数Day(DateSerial(2010, n+1,0))
Format(Date, "aaaa") '星期几
Format(Date, "yyyy") '年
Format(Date, "m") '月
Format(Date, "d") '日
Application.Wait Now + TimeValue("00:00:05")'延时执行
Sub 缓缓输入句子()
m = Array("好", "好", "学", "习", "天", "天", "向", "上")
For i = 0 To 7
Application.Wait Now + TimeValue("00:00:02") ' 延时执行
[D5] = [D5] & m(i)
Next
End Sub
CreateObject("SAPI.SpVoice").Speak h & "秒" '语音读出
判断英文字母：Mid("S好tr", 3, 1) Like "[a-zA-Z]" '