VBA 笔记本
《EXCELVBA》
■单元格格式
◆字体颜色、背景色
Selection.Interior.ColorIndex = 10‘绿色
注：ColorIndex = 40 茶色（土黄色）ColorIndex = 38 粉红色
[F32].Font.Color = RGB(0, 255, 0)
TextBox.ForeColor = RGB(156, 128, 0)
注：RGB(1, 255, 2)函数值计算方法：1 * 0 + 255 * 256 + 2 * 256 * 256
◆内部字符的格式
下面代码：将单元格内从第3个字符开始选取5个字符，将其字体大小设置为8号
Cells(1，1).Characters(Start:=3, Length:=5).Font.Size = 8
◆边框
Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
扩展：①xlEdgeLeft左边框 xlEdgeRight右边框 xlEdgeTop上边框 xlEdgeBottom下边框 xlInsideHorizontal内部垂直边框xlInsideVertical 内部水平边框
②LineStyle 线条样式
xlContinuous 单线 xlDouble 双线 xlDot 虚点 xlDashDotDot
③Weight=xlThin 细线 xlThick 粗 xlMedium 中粗
◆单元格→对齐
Selection.HorizontalAlignment = xlGeneral 水平对齐 = 常规
.VerticalAlignment = xlBottom 垂直对齐 = 靠下
.WrapText = True自动换行
.MergeCells = False合并单元格
.ShrinkToFit = False缩小字体填充
.AddIndent = True自动缩进
.IndentLevel = 2 缩进字数
扩展：①HorizontalAlignment 水平对齐
xlGeneral 常规 xlLeft靠左（缩进） xlRight靠右（缩进）
xlCenter居中xlJustify两端对齐xlFill填充
②VerticalAlignment 垂直对齐
xlCenter 居中xlBottom靠下xlJustify 两端对齐xlDistributed 分散对齐
◆单元格→数字格式
Selection.NumberFormatLocal = "0.000_ " '数值保留3位小数
Selection.NumberFormatLocal = "0.00_ " '数值保留2位小数
Selection.NumberFormatLocal = "0.0_ " '数值保留1位小数
Selection.NumberFormatLocal = "0_ " '数值保留0位小数
Selection.NumberFormatLocal = "G/通用格式" '常规
Selection.NumberFormatLocal = "yyyy-m-d" '日期
Selection.NumberFormatLocal = "0.00_);[红色](0.00)" '数值保留2位小数负数用括号如图所示
■Range 操作
[A1:C10].Address= "$A$1:$C$10" [A1:C10].Count=30
注：Clear方法 Copy方法 Cut方法 Paste方法
Cells(3,2)可改成Cells("3","B")
◆批量赋值
Range("G2:H2500").Value = Range("Q2:R2500").Value‘即：直接将某区域的值复制到另一个单元格区域
◆复制、粘贴
ActiveCell.Offset(0, -5).Columns("A:G").EntireColumn.Select
Selection.Copy
ActiveCell.Offset(0, 8).Columns("A:A").EntireColumn.Select
ActiveSheet.Paste
◆选择性粘贴
Selection.Copy '复制
Selection.PasteSpecial Paste:=xlPaste For mats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False 扩展：xlPaste For mats表示：选择性粘贴→格式
xlPasteValues 数值 xlPaste For mulas公式xlPasteComments批注xlPasteColumnWidths列宽
附：Application.CutCopyMode = False
◆设置行高、列宽
Rows(i).RowHeight 行高 Columns(i).ColumnWidth 列宽
◆删除单元格
Selection.Delete Shift:=xlUp 删除单元格（区域）
【扩展】xlUp表示下方单元格上移 xlDown下移
xlToLeft 左移 xlToRight 右移
Selection.EntireRow.Delete 删除整行
Selection.EntireColumn.Delete 删除整列
Rows(5).Delete 删除第5行
Columns(8).Delete 删除第8列
◆插入单元格
Selection.Insert Shift:=xlDown '插入单元格（区域）→当前单元格下移
【扩展】xlToRight→当前单元格右移
Selection.EntireRow.Insert '→插入整行单元格
Selection.EntireColumn.Insert '→插入整行单元格
◆选中单元格
Application.Goto Reference:="名称"选中指定名称的单元格区
选择不连续的单元格区 Range("A1:A3,B8,E12").Select
选中活动单元格所在列的第1个单元格
ActiveCell.Offset(-ActiveCell.Row+1,0).Select
利用名称选中Range
Sheet2.Range("A2:F12,Price").Select 注:Price是自定义名称
◆隐藏行、列代码
Rows(i).Hidden = True Rows.Hidden = False显示全部
◆计算行列数
Selection.Row 首行Selection.Column 首列
◆Cells.Find查找搜索功能、按格式查找
①Application.FindFormat.Clear
②Application.FindFormat.Font.Size = 10
③Application.FindFormat.Font.ColorIndex = 3
④Cells.Find(What:="中国", After:=ActiveCell, LookIn:=xlFormula, LookAt:=xlPart, Searchorder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, MatchByte:=False, SearchFormat:=True).Activate
解释：上述代码功能相当于菜单中的查找操作，查找内容为“中国”的单元格（而且符合上述格式）
Cells.FindNext(After:=ActiveCell).Activate
扩展：①LookIn:=xlFormulas→公式 xlValues→值 xlComments→批注
②LookAt:=xlPart→模糊查找 xlWhole→精确查找
③SearchOrder:=xlByRows→按行xlByColumns→按列
④MatchCase:=False不区分大小写
⑤Searc hForma t:=True格式查找起作用
注：上述参数除What外，都可以省略。Cells是一个Range，所以可以用任何Range代替Cells.例如：Range.Find()
◆批注Comment
①增加、修改批注
If Cells(1,1).Comment Is Nothing Then
Cells(1,1).AddComment
Cells(1,1).Comment.Text Text:= "批注内容"
EndIf
②批注自动适应文字大小
Cells(1,1).Comment.Shape.TextFrame.AutoSize = True
③删除批注
Cells(1,1).ClearComments
④隐藏批注
Cells(1,1).Comment.Visible=False
◆单元格区域取名的方法
Range("A1:F10").Name= "Price"命名
Names("Price").Name="BookPrice"改名
Names("BookPrice").Delete删除名字
https://www.wendangku.net/doc/5f16088579.html,s.Add Name:="现金科目",
RefersToR1C1:= "=科目表!R3C2:R8C2"
https://www.wendangku.net/doc/5f16088579.html,s.Add Name:="第一区",
RefersToR1C1:="=信息表!R3C2:R"& i &"C7"【使用变量】
◆Range.AutoFill【自动填充】
本示例以工作表 Sheet1 上的单元格区域 A1:A2 为基础，对单元格区域 A1:A20 进行自动填充。运行本示例之前，请在单元格 A1 中键入1，在单元格 A2
◆Range("A1").NumberFormatLocal
返回单元格数字格式名字【Ctrl+1单元格格式→数字→自定义】
◆自定义筛选
例如：第一步：筛选第1列包含"江西"或"宜春"的记录
ActiveSheet.[A1].CurrentRegion.Select
Selection.AutoFilter Field:=1, Criteria1:="=*江西*", Operator:=xlOr, Criteria2:="=*宜春*"
第二步：在结果中，继续筛选第2列包含"宜春"或"丰城"的记录
Selection.AutoFilter Field:=2, Criteria1:="=*宜春*", Operator:=xlOr, Criteria2:="=*丰城*"
第三步：取消自动筛选，显示全部数据
Selection.AutoFilter注：显示和取消自动筛选是同一条命令
ActiveSheet.ShowAllData
注：Operator:=xlAnd Criteria1:="=?中国*"
Criteria2:="<>北京"
Criteria2:="<>*安徽*"表示：不包含"安徽"
◆单元格排序
扩展：xlAscending 升序 =1 xlDescending 降序 =2 xlYes 有标题 =1 xlNo 无标题 =2
◆自定义排序
Dim n AsInteger
n = Application.CustomListCount
Application.AddCustomList (Worksheets("Sheet3").Range("b3:b12"))
Range("b3:g12").Sort key1:=Range("b2"), order1:=xlAscending, OrderCustom:=n + 2
Application.DeleteCustomList n + 1
说明：
1. Application.CustomListCount属性返回工作簿中所有自定义序列的数量。Excel默认已内置了11个自定义序列。在用户没有添加自定义序列的情况下，Application.CustomListCount的值为11。
n = Application.CustomListCount语句在排序前先取得自定义列表中的自定义序列数量。
2. Range.Sort 方法中包含参数“OrderCustom”表明进行自定义排序，同时“OrderCustom”参数的值指明用哪个自定义序列排序。从Excel 2003的“排序选项”对话框中可以看出，默认的排序方法为“普通”，当省略OrderCustom参数或指定其值为1时，则按“普通”（即非自定义序列）方法排序。当使用自定义排序时，将“OrderCustom”参数设置为指定的序列在自定义列表中的顺序加1即可。如自定义序列“一月,二月……,十二月”在下图中的位置为8，如果要用该自定义序列排序，则需指定OrderCustom的值为8。
◆批量读取单元格区域的值给数组
Dim Arr As Variant '一定要是变体类型，否则会出错
注：声明数组时，可以指定上下标，也可以不指定；指定时无效，默认为从（1，1）开始二维数组
注2：该工作表一定要激活状态，否则也会报错
Arr = Range("A1:B100").Value
Arr = Range("A1:A100").Address
Arr = Range("A1:A100").Interior.ColorIndex
◆数据有效性→序列
With Selection.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:="资产类,负债类,权益类,收入类,支出类"
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.IMEMode = xlIMEModeNoControl
.ShowInput = True
.ShowError = True
EndWith
◆单元格名称2003
Sub删除单元格名称()
Dim myName As Name, i AsLong, n AsLong
If MsgBox("您确定要删除所有工作表的单元格名称吗？", vbYesNo, "再次确认") = vbNo Then Exit Sub
For i = 1 To ThisWorkbook.Sheets.Count
ForEach myName In Sheets(i).Names
If InStr(https://www.wendangku.net/doc/5f16088579.html,, "Print_Area") = 0 Then
myName.Delete
n = n + 1
EndIf
Next
Next i
MsgBox "共删除：" & n & " 个名称", , "执行完成"
EndSub
◆单元格名称2007
注：Ctrl+F3 打开名称管理器
Sub删除单元格名称()
Dim myName As Name, i AsLong, n AsLong
If MsgBox("您确定要删除所有工作表的单元格名称吗？", vbYesNo, "再次确认") = vbNo Then Exit Sub
ForEach myName In https://www.wendangku.net/doc/5f16088579.html,s
If InStr(https://www.wendangku.net/doc/5f16088579.html,, "Print_Area") = 0 Then
myName.Delete
n = n + 1
EndIf
Next
MsgBox "共删除：" & n & " 个名称", , "执行完成"
EndSub
■WorkSheet操作
Dim Sheet1 As WorkSheet
Set Sheet1=WorkSheets.Add添加工作表或Set Sheet1=WorkSheets.Add (Before:=Sheets(1))
◆插入一张新表
Sheets.Add 同样Workbook.Add （插入工作薄）Sheet1.Delete 删除指定工作表
◆复制或移动工作表
Sheets("学生表").Move Before:=Sheets(2) 移动工作表
Sheets("学生表").Move After:=Sheets(1)
Sheets("学生表").Copy Before:=Sheets(2) 复制工作表
◆Worksheet.EnableSelection 属性
仅当工作表处于保护状态时，本属性才能起作用：
xlNoSelection防止在工作表上进行任何选择操作，
xlUnlockedCells仅允许Locked属性为False的单元格才能被选定，
xlNoRestrictions允许选定任意单元格
◆撤销工作表保护密码
Sub撤销工作表保护密码()
Dim i AsLong, S AsString
On Error Resume Next
For i = 1 To 10
S = i
ActiveSheet.Unprotect Password:=S
If ActiveSheet.ProtectContents = FalseThen
Next i
EndSub
◆WorkSheet.Protect 参数介绍
Password 一个字符串，该字符串为工作表或工作簿指定区分大小写的密码。如果省略此参数，不用密码就可以取消对工作表或工作簿的保护。DrawingObjects 如果为True，则保护形状。默认值是True。
Contents 如果为True，则保护内容。对于图表，这样会保护整个图表。对于工作表，这样会保护锁定的单元格。默认值是True。
Scenarios 如果为True，则保护方案。此参数仅对工作表有效。默认值是True。
UserInterfaceOnly 如果为True，则保护用户界面，但不保护宏。如果省略此参数，则既保护宏也保护用户界面。
Allow For mattingCells 如果为True，则允许用户为受保护的工作表上的任意单元格设置格式。默认值是False。
Allow For mattingColumns 如果为True，则允许用户为受保护的工作表上的任意列设置格式。默认值是False。
Allow For mattingRows 如果为True，则允许用户为受保护的工作表上的任意行设置格式。默认值是False。
AllowInsertingColumns 如果为True，则允许用户在受保护的工作表上插入列。默认值是False。
AllowInsertingRows 如果为True，则允许用户在受保护的工作表上插入行。默认值是False。
AllowInsertingHyperlinks 如果为True，则允许用户在受保护的工作表中插入超链接。默认值是False。
AllowDeletingColumns 如果为True，则允许用户在受保护的工作表上删除列，要删除的列中的每个单元格都被解除锁定。默认值是False。AllowDeletingRows 如果为True，则允许用户在受保护的工作表上删除行，要删除的行中的每个单元格都被解除锁定。默认值是False。AllowSorting 如果为True，则允许用户在受保护的工作表上进行排序。排序区域中的每个单元格必须是解除锁定的或取消保护的。默认值是False。AllowFiltering 如果为True，则允许用户在受保护的工作表上设置筛选。默认值是False。
AllowUsingPivotTables 如果为True，则允许用户在受保护的工作表上使用数据透视表。默认值是False。
◆工作表保护密码破解
Sub工作表保护密码破解()
Const DBLSPACE AsString = vbNewLine & vbNewLine
Const AUTHORS AsString = DBLSPACE & vbNewLine & _
"作者:McCormick JE McGimpsey "
Const HEADER AsString = "工作表保护密码破解"
Const VERSION AsString = DBLSPACE & "版本 Version 1.1.1"
Const REPBACK AsString = DBLSPACE & ""
Const ZHENGLI AsString = DBLSPACE & " hfhzi3—戊冥整理"
Const ALLCLEAR AsString = DBLSPACE & "该工作簿中的工作表密码保护已全部解除!!" & DBLSPACE & "请记得另保存" _
& DBLSPACE & "注意：不要用在不当地方，要尊重他人的劳动成果！"
Const MSGNOPWORDS1 AsString = "该文件工作表中没有加密"
Const MSGNOPWORDS2 AsString = "该文件工作表中没有加密2"
Const MSGTAKETIME AsString = "解密需花费一定时间,请耐心等候!" & DBLSPACE & "按确定开始破解!"
Const MSGPWORDFOUND1 AsString = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _
"如果该文件工作表有不同密码,将搜索下一组密码并修改清除"
Const MSGPWORDFOUND2 AsString = "密码重新组合为:" & DBLSPACE & "$$" & DBLSPACE & _
"如果该文件工作表有不同密码,将搜索下一组密码并解除"
Const MSGONLYONE AsString = "确保为唯一的?"
Dim w1 As Worksheet, w2 As Worksheet
Dim i AsInteger, j AsInteger, k AsInteger, l AsInteger
Dim m AsInteger, n AsInteger, i1 AsInteger, i2 AsInteger
Dim i3 AsInteger, i4 AsInteger, i5 AsInteger, i6 AsInteger
Dim PWord1 AsString
Dim ShTag As Boolean, WinTag As Boolean
Application.ScreenUpdating = False
With ActiveWorkbook
WinTag = .ProtectStructure Or .ProtectWindows
EndWith
ShTag = False
ForEach w1 In Worksheets
ShTag = ShTag Or w1.ProtectContents
Next w1
If Not ShTag And Not WinTag Then
MsgBox MSGNOPWORDS1, vbInformation, HEADER
Exit Sub
EndIf
MsgBox MSGTAKETIME, vbInformation, HEADER
If Not WinTag Then
Else
On Error Resume Next
Do 'dummy do loop
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
With ActiveWorkbook
.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _
Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If .ProtectStructure = False And _
.ProtectWindows = FalseThen
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
MsgBox Application.Substitute(MSGPWORDFOUND1, _
"$$", PWord1), vbInformation, HEADER
Exit Do 'Bypass all for...nexts
EndIf
EndWith
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
Loop Until True
On Error Goto 0
EndIf
If WinTag And Not ShTag Then
MsgBox MSGONLYONE, vbInformation, HEADER
On Error Resume Next
ForEach w1 In Worksheets
'Attempt clearance With PWord1
w1.Unprotect PWord1
Next w1
On Error Goto 0
ShTag = False
ForEach w1 In Worksheets
'Checks for all clear ShTag triggered To 1 If not.
ShTag = ShTag Or w1.ProtectContents
Next w1
If ShTag Then
ForEach w1 In Worksheets
With w1
If .ProtectContents Then
On Error Resume Next
Do 'Dummy do loop
For i = 65 To 66: For j = 65 To 66: For k = 65 To 66
For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66
For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66
For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126
.Unprotect Chr(i) & Chr(j) & Chr(k) & _
Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
If Not .ProtectContents Then
PWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _
Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _
Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
MsgBox Application.Substitute(MSGPWORDFOUND2, _
"$$", PWord1), vbInformation, HEADER
'leverage finding Pword by trying on other sheets
ForEach w2 In Worksheets
w2.Unprotect PWord1
Next w2
Exit Do 'Bypass all for...nexts
EndIf
Next: Next: Next: Next: Next: Next
Next: Next: Next: Next: Next: Next
Loop Until True
On Error Goto 0
EndIf
EndWith
Next w1
EndIf
MsgBox ALLCLEAR & AUTHORS & VERSION & REPBACK & ZHENGLI, vbInformation, HEADER
EndSub
Sub选中多个工作表()
Worksheets(Array("Sheet1", "Sheet2", "Sheet4")).Select
EndSub
■WorkBook操作
◆新建工作薄
Dim Book1 As WorkBook
Set Book1 = WorkBooks.Add 新建工作薄
https://www.wendangku.net/doc/5f16088579.html, = "乡财务记账系统"新建工作薄改名字
ChDir "D:\桌面"
◆另存为(版本号)
If Application.Version = "11.0" Then'如果是Excel2003
SystemBook.SaveAs FileName:= "乡财务.xls", FileFormat:=xlNormal, CreateBackup:=False(FileFormat:=xl Excel) ElseIf Application.Version = "12.0" Or Application.Version = "14.0"Then'如果是Excel2007 2010 2013
SystemBook.SaveAs FileName:= "乡财务.xlsb", FileFormat:=xlExcel12, CreateBackup:=False
EndIf
Book1.SaveAs FileName:="D:\安装\乡财务.xls"另存为(方法1)
Book1.SaveAs("D:\安装\乡财务.xls") 另存为(方法2)
Book1.SaveAs(Book2.Path &"\乡财务.xls") 另存为(方法3)
◆保存属性
WorkBooks("乡财务.xls").Saved = True
Workbooks("乡财务.xls").Close SaveChanges:=False关闭工作薄放弃更改
例：保存所有打开的工作簿，然后退出 Microsoft Excel。
ForEach w In Application.Workbooks
w.Save
Next w
Application.Quit
◆不打开文件而直接操作Workbook(后台打开)
Dim Book AsObject
Set Book = GetObject(ThisWorkbook.Path &"\学生表.xls")
Book.Close (False)‘用完后需要关闭文件(这种方式只能读取，不能写入)
Set Book = Nothing
◆工作表和工作薄的保护密码
①Sheet2("科目表").Protect Password:="123456"
②ActiveWorkbook.Password = "abc"
③打开含密码的Workbook时
Workbooks.Open("D:\学生.xls"),Password:="abc"
④设置工作薄的只读密码
ActiveWorkbook.WritePassword="abc"
注：取消密码只要设置为空字符串即可
Book1.Sheets.Count
■Application环境
Application.DisplayAlerts = False关闭Excel弹出的警告提示
Application.DisplayFullScreen = False【全屏显示】
Application.EnableEvents = False【关闭事件】
ActiveWorkbook.RemovePersonalInformation = False工具→选项→安全性→保存时从文件属性中删除个人信息
Appliction.Volatile 【自定义函数重算】
ActiveWorkbook.RemovePersonalInformation = False保存时从文件属性中删除个人信息
Appliction.Caption = "记账系统"
ActiveWindow.Caption = ""【常和上句联用】
Application.CutCopyMode = False【复制模式】
ActiveWindow.Zoom = 85【视图显示比例85%】
Application.WindowState = xlMaximized【最大化-Excel窗口状态】
ActiveWindow.WindowState = xlMinimized【最小化-工作薄窗口状态】
Application.StatusBar = "就绪"‘工作表底部状态栏显示的文字提示
【注】xlNormal一般化 xlMinimized最小化
Application.FreezePanes =True【冻结窗口】
Application.ReferenceStyle = xlR1C1设置R1C1引用样式
Application.ReferenceStyle = xlA1设置A1引用样式
ActiveWindow.ScrollColumn = 4 将第4列拖至最左端
ActiveWindow.ScrollRow = 5 将第5行拖至最上端
Worksheets(2).ScrollArea = "A1:B32"或者 = Range("A1:B32").Address
隐藏功能
https://www.wendangku.net/doc/5f16088579.html,mandBars("Worksheet Menu Bar").Enabled = False【菜单】
Appliction.DisplayFormulaBar = True【公式编辑栏】
Appliction.DisplayWorkbookTabs = True【工作表标签】
ActiveWindow.DisplayHeadings = False【行列号】
ActiveWindow.DisplayGridlines = False【网格线】
ActiveWindow.DisplayHorizontalScrollBar = False【水平滚动条】
ActiveWindow.DisplayVerticalScrollBar = False【垂直滚动条】
隐藏常用工具栏
https://www.wendangku.net/doc/5f16088579.html,mandBars("Standard").Visible = False（2003版）
或 https://www.wendangku.net/doc/5f16088579.html,mandBars(3).Enabled = True
隐藏格式工具栏
https://www.wendangku.net/doc/5f16088579.html,mandBars("Formatting").Visible = False（2003版）
或 https://www.wendangku.net/doc/5f16088579.html,mandBars(4).Enabled = True
废除功能
◆https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Enabled =False'废除单元格右键菜单功能
【注】"cell"代表单元格右键；"ply"代表工作表标签右键； "autocalculate"代表状态栏右键；"toolbar list"代表工具栏右键（"ToolBar"2003版）◆https://www.wendangku.net/doc/5f16088579.html,mandBars(3).Controls(3).Enabled = False'使常用工具栏中第三个"保存"是否可用
◆https://www.wendangku.net/doc/5f16088579.html,mandBars(1).Controls(1).Enabled = False'使菜单中的"文件"是否可用
◆https://www.wendangku.net/doc/5f16088579.html,mandBars("file").Controls("页面设置(&U)...").Enabled =False'菜单中的"文件"中的"页面设置"是否可用
◆https://www.wendangku.net/doc/5f16088579.html,mandBars(1).Controls(4).Enabled = False'菜单中的第四个"插入"是否可用
◆https://www.wendangku.net/doc/5f16088579.html,mandBars(1).Controls(4).Caption = "victor"'更改子菜单名称
◆重置菜单功能
◆https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Reset '重置单元格右键菜单
◆https://www.wendangku.net/doc/5f16088579.html,mandBars(1).Reset '重置主菜单或 https://www.wendangku.net/doc/5f16088579.html,mandBars("worksheet menu bar").Reset
◆https://www.wendangku.net/doc/5f16088579.html,mandBars(3).Reset重置常用工具栏
◆https://www.wendangku.net/doc/5f16088579.html,mandBars(4).Reset 重置格式工具栏
取消单元格锁定
Selection.Locked = False
VBA语音代码
Application.Speech.SpeakCellOnEnter=True
Application.Speech.Speak "要读出的文字"
Application.CutCopyMode 属性
返回或设置剪切或复制模式的状态。可为True、False或如下表所示的一个 XLCutCopyMode 常量，Long类型以下3种使用
①False不处于剪切或复制模式②xlCopy 处于复制模式③xlCut 处于剪切模式。
SelectCase Application.CutCopyMode
CaseIs = False
MsgBox "Not in Cut or Copy mode"
CaseIs = xlCopy
MsgBox "In Copy mode"
CaseIs = xlCut
MsgBox "In Cut mode"
End Select
■打印相关
设置当前区域为打印区域
ActiveSheet.PageSetup.PrintArea = ActiveCell.CurrentRegion.Address
WorkSheets("总账").PageSetUp.PrintArea = "$A$1:$E$20"'注："$A$1:$E$20" = [A1:E20].Address
将多个区域设置为打印区域(分页打印)
Sheet2.PageSetup.PrintArea = "A1:B5,A11:E20"
动态设置打印区域，利用变量
Sheet2.PageSetup.PrintArea="A1:G"& i
将打印区域打印出来
Sheet1.PrintOut Copies:=2,Collate:=True'注:Collate勾选"逐份打印"
设置打印区
https://www.wendangku.net/doc/5f16088579.html,s.Add "PrintArea",Sheet1.Range("A1:C10")
获取打印页数
打印页数 = ExecuteExcel4Macro("Get.Document(50)")
打印页数 = ActiveSheet.PageSetup.Pages.Count'Application.ScreenUpdating = True时才准确(Excel2003中不可用)
页面设置
With ActiveSheet.PageSetup
.PrintTitleRows = ""'◆打印标题行
.PrintTitleColumns = ""'◆打印标题列
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "同田乡政府" '◆页脚:左边
.CenterFooter = "第" & 页码 & "页" '◆页脚：中间
.RightFooter = 页码'◆页脚：右边
.LeftMargin = Application.InchesToPoints(0.1) '◆页边距：左
.RightMargin = Application.InchesToPoints(0.2) '◆页边距：右
.TopMargin = Application.InchesToPoints(0.4) '◆页边距：上
.BottomMargin = Application.InchesToPoints(0.5) '◆页边距：下
.HeaderMargin = Application.InchesToPoints(0.1) '◆页边距：页眉
.FooterMargin = Application.InchesToPoints(0.25) '◆页边距：页脚
.Zoom = 66 '◆缩放比例：设为66%
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = True'◆居中方式：水平居中
.CenterVertically = False '◆居中方式：垂直居中
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperA4'◆纸张大小：设为A4
.FirstPageNumber = xlAutomatic'◆起始页码：设为“自动”
.Order = xlDownThenOver
.BlackAndWhite = False
.PrintErrors = xlPrintErrorsDisplayed
EndWith
数组
清空数组Erase
Erase SimpleJF: Erase SimpleDF '释放数组
■LBound和UBound
n1 = LBound(ArrayJF())
n2 = UBound(ArrayJF())
如果是多维数据:ArrayX(1 To 300,1 To 500)
那么LBound(ArrayX,1)=300
LBound(ArrayX,2)=500
ReDim数组
ReDim SimpleJF(n1 To n2)
ReDim Preserve SimpleJF(n1 To n2)
a = Array(2, 6.5, 7, 20.4, 100, 920)
常用VBA代码
自定义类型
Public Type Student
name AsString
sex AsString
score AsLong
End Type
单元格内写入公式
◆[E10].Formula = "=C"& i &"-D"& j 相当于=C10-D9【当i=10 j=9】
也可以直接[E10] = "=C"& i &"-D"& j
◆求活动单元格上面20个单元格区的和
ActiveCell.For mula="=Sum(R[-21]C:R[-1]C)" 注：相对引用
◆求A1:B10之和
ActiveCell.For mula="=Sum(R1C1:R10C2)" 注：绝对引用
注：上面两个求和公式，其中For mula可用For mulaR1C1代替
◆移动艺术字
ActiveSheet.Shapes("WordArt1").Select
Selection.ShapeRange.Increment Left -120
◆选中工作表中的Shape对象
①ActiveSheet.Shapes.SelectAll
②ActiveSheet.Shapes.Range(Array(1,3)).Select
注意：①选择所有图形对象②选择1和3图形对象
◆VBA使用工作表函数
Cells(1, 2) = WorksheetFunction.CountA(UsedRange) + 1
UsedRange：代表工作表中已使用的单元格区域
CountA()：工作表函数，含有字符的单元格的个数
WorksheetFunction：在VBA中调用工作表函数的调用格式
Cells(1, 2) = Application.WorksheetFunction.Sum(Worksheets("Sheet1").Range(Cells(1, 2), Cells(4, 2)))
◆人民币大写函数
Function DX(M)'例如：负伍圆陆角伍分
Dim a
DX = Replace(Replace(Replace(Join(Application.Text(Split(For mat(M, " 0. 0 0;负 0. 0 0; ")), ["[DBnum2]"&{0,"","圆0角;;圆零","0分;;整"}]), a), "零圆零", a), "零圆", a), "零整", "整")
End Function
◆错误处理语句
On Error Resume NextOn Error Goto行号On Error Goto 0
◆Optional可选参数
Sub text(n AsLong, Optional c AsString = "朱艳")
解释：Optional关健字表示后面所有参数都是可选的，不能出现非Optional参数
例如：Sub text(n AsLong, Optional c AsString = "朱艳", Optional d AsLong = 2) 是正确的，如果去掉后来的Optional关健字就会出错
Sub test5(n AsLong, ParamArray c() As Variant)
以省略
◆IIF语句
i = IIF(a > 0，1，2)
加载宏
导入加载宏
AddIns.Add FileName:= "C:\Users\Administrator\AppData\Roaming\Microsoft\AddIns\记账系统.xla" AddIns("记账系统").Installed = True
卸载加载宏
AddIns("记账系统").Installed = False
调用加载宏函数
Cells(2, 6).Value = Application.Run("通用函数.xla!修正小数", "0.101")
《案例汇编》
◆输入时逐步提示效果
在Worksheet输入数据时，右方弹出逐步提示框
ListBox.ListCount 列表框Item个数
ListBox.List(0) 第1个Item值
ListBox.AddItem "Item01"添加项目
ListBox.Clear 清空Item下拉选项
◆自定义函数
Function PinYin(ByVal Tstr As String) As String
i = As c(Tstr)
If i >= As c("啊") And i If i >= As c("芭") And i If i >= As c("擦") And i If i >= As c("搭") And i If i >= As c("蛾") And i If i >= As c("发") And i If i >= As c("噶") And i If i >= As c("哈") And i If i >= As c("击") And i If i >= As c("喀") And i If i >= As c("垃") And i If i >= As c("妈") And i If i >= As c("拿") And i If i >= As c("哦") And i If i >= As c("啪") And i If i >= As c("欺") And i If i >= As c("然") And i If i >= As c("撒") And i If i >= As c("塌") And i If i >= As c("挖") And i If i >= As c("昔") And i If i >= As c("压") And i If i >= As c("匝") And i <= As c("座") Then PinYin = "z" EndFunction ◆数据Worksheet代码【为汉字添加拼音字母】 PrivateSub Worksheet_SelectionChange(ByVal Target As Range) Target.Offset(0, 1) = "" For i = 1 To Len(Target) temp = As c(Mid$(Target, i, 1)) If temp > 255 Or temp < 0 Then '如果是中文字符，利用PinYin()函数转成小写首字母 Target.Offset(0, 1) = Target.Offset(0, 1) & PinYin(Mid(Target, i, 1)) Else'如果是英文字符,只要转成小写字母 Target.Offset(0, 1) = Target.Offset(0, 1) & LC as e(Mid(Target, i, 1)) End If Next EndSub ◆输入WorkSheet代码 PrivateSub Worksheet_SelectionChange(ByVal Target As Range) '限制只在第3列的空单元格起作用 If ActiveCell.Column = 3 Then TextBox1 = "" TextBox1.Visible = True TextBox1.Top = Target.Top TextBox1.Left = Cells(ActiveCell.Row, ActiveCell.Column).Left TextBox1.Width = ActiveCell.Width ListBox1.Clear ListBox1.Visible = True ListBox1.Top = Target.Top + 18 ListBox1.Left = Cells(ActiveCell.Row, ActiveCell.Column).Left ListBox1.Width = ActiveCell.Width Else ListBox1.Clear TextBox1 = "" ListBox1.Visible = False TextBox1.Visible = False EndSub ◆TextBox控件的KeyUp事件代码 PrivateSub TextBox1_KeyUp(ByVal KeyCode As MS For ms.ReturnInteger, ByVal Shift As Integer) '【假设:数据在第1列，拼音在第2列】 If TextBox1 = ""ThenExitSub ListBox1.Clear For i = 1 To Len(TextBox1) temp = As c(Mid$(TextBox1, i, 1)) If temp > 255 Or temp < 0 Then'输入文本框中字符有中文时. For j = 2 To Sheets("数据表").Cells(2, 1).End(xlDown).Row If LCase(TextBox1) = Left(Sheets("数据表").Cells(j, 1), Len(TextBox1)) Then ListBox1.AddItem(Sheets("数据表").Cells(j, 1)) End If Next Else For j = 2 To Sheets("数据表").Cells(2, 1).End(xlDown).Row If LCase(TextBox1) = Left(Sheets("数据表").Cells(j, 2), Len(TextBox1)) Then ListBox1.AddItem(Sheets("数据表").Cells(j, 1)) End If Next End If Next EndSub ◆ListBox代码 PrivateSub ListBox1_DblClick(ByVal Cancel As MS For ms.ReturnBoolean) ActiveCell.Value = ListBox1.Value ListBox1.Clear TextBox1 = "" ListBox1.Visible = False TextBox1.Visible = False EndSub ◆限制Excel只能在本机运行 拷贝到其它机器运行时进行限制 Sub Auto_Open() Dim fso, d, s fso = CreateObject("Scripting.FileSystemObject") d = fso.GetDrive(fso.GetDriveName(fso.GetAbsolutePathName( ThisWorkbook.Path))) s = d.serialnumber '磁盘序列号 If s = VFJ161R71TY6XK ThenExitSub'要使用的电脑磁盘序列号 Dim FirstDate, de, days FirstDate = Date de = Get Set ting("XXX", "YYY", "date", "") '从注册表取值 If de = ""Then'如果取不到值 Save Set ting("XXX", "YYY", "date", FirstDate) '把日期保存到注册表 MsgBox("本文件可使用3天，今天是第1次使用", , "提示") Else days = Date - CDate(de) '计算文件使用的天数 If days < 3 Then'如果文件使用超过3天 If MsgBox("已超过使用期限，本文件将自杀", vbYesNo, "警告") = vbNo ThenExitSub End If If MsgBox("请确认删除本文件", vbYesNo, "警告") = vbNo ThenExitSub ThisWorkbook.ChangeFileAccess(xlReadOnly) '改为只读属性 Kill(ThisWorkbook.FullName) '自杀 ThisWorkbook.Close(False) '关闭不保存 End If MsgBox "本文件已使用"& days &"天，还有"& 3 - days &"天可使用" End If EndSub ◆怎样使用户窗体随当前单元格精确移动 PrivateSub Worksheet_SelectionChange(ByVal Target As Range) With User For m1 .Show(0) .Top = Target.Top .Left = Target.Left End With ◆快速隐藏周围区域 Dim CelFirst As Range, CelL as t As Range IfNot Selection IsNothingThen With Selection '当前选中区域的第一个单元格 CelFirst = .Cells(1) '当前选中区域的最后一个单元格 CelLast = .Cells(.Cells.Count) End With If CelFirst.Address <>"$A$1"Then’【隐藏左上区】 With Range([A1], CelFirst.Offset(I If(CelFirst.Row = 1, 0, -1), I If(CelFirst.Column = 1, 0, -1))) '如果当前选中区域不包括第一行，则隐藏蓝色区域所在的行 If CelFirst.Row <> 1 Then .EntireRow.Hidden = True '如果当前选中区域不包括第一列，则隐藏蓝色区域所在的列 If CelFirst.Column <> 1 Then .EntireColumn.Hidden = True End With End If If CelLast.Address <>"$IV$65536"Then’【隐藏右下区】 With Range(CelLast.Offset(I If(CelLast.Row = 65536, 0, 1), I If(CelLast.Column = 256, 0, 1)), [IV65536]) If CelLast.Row <> 65536 Then .EntireRow.Hidden = True If CelLast.Column <> 256 Then .EntireColumn.Hidden = True End With End If End If ◆限制文本框只能输入数字 例如，假设将用户窗体中的文本框命名为TextBox1，下面的代码将允许在文本框中输入数字0-9、一个句点和负号。代码限制用户输入的数据中包含小数点，并且只局限于将负号作为第一个字符输入。 PrivateSub TextBox1_KeyPress(ByVal KeyAscii As MS For ms.ReturnInteger) SelectC as e Key As cii Case As c("0") To As c("9") Case As c("-") If Instr(1, Me.TextBox1.Text, "-") > 0 OrMe.TextBox1.SelStart > 0 Then Key As cii = 0 End If C as e As c(".") If InStr(1, Me.TextBox1.Text, ".") > 0 Then Key As cii = 0 End If C as eElse Key As cii = 0 EndSelect EndSub 《窗体和控件》 遍历窗体控件 方法一：利用变量【窗体控件】 For i = 1 To 50 Me.Controls("CheckBox"& i).Value = False Next 方法二：利用Control对象【窗体控件】 Dim c As Control ForEach c In Me.Controls if TypeName(c) = "TextBox" Then ……您的代码…… End If Next https://www.wendangku.net/doc/5f16088579.html,mandButton1.Enabled = True 方法三：利用Name属性【窗体控件】 ForEach c In Me.Controls If https://www.wendangku.net/doc/5f16088579.html, Like"TextBox*" Then ……您的代码…… End If Next 遍历WorkSheet控件 方法一: 【WorkSheet控件】 For i = 1 To 3 Me.OLEObjects("CheckBox"& i).Object.Value = False Next 方法二：利用程序标志符【WorkSheet控件】 Dim S As Shape ForEach S In Sheet1.Shapes If S.OLEFormat.progID = "Forms.ToggleButton.1" Then S.Height = Range("A1").Height End If Next ■将控件作为函数参数的错误 Sub 科目列表框逐步提示(MyComboBox As Control) 正确 Sub 科目列表框逐步提示(MyComboBox As ComboBox) 错误参数类型不正确 If MyControl Is Nothing Then ■控件获得焦点 TextBox.SetFocus 正确 TextBox1.SetFocus '不知道你知道这些不,只管解释了一下,这里是设置焦点 TextBox1.SelStart = Len(Me.TextBox1.Text) – 3 '设置文本长度并设置光标位置 CommandButton.Activate ■ListBox ListBox1.Clear '清除所有Item ListBox.AddItem ("联合") ListBox1.ListCount '下拉列表项数量 ListBox1.List(0) = "" '第一项值 '下面两行，只针对工作表中的ListBox控件 ListBox1.Top = Cells(3,3).Top ListBox1.Left = Cells(3,3).Left + Cells(3,3).Width ■RichTextBox的添加方法 工具箱→附加控件→Microsoft Rich Textbox Control 6.0 ■RichTextBox使用后，会弹出警告框的解决方法 Sub ControlAx() Dim WshShell As Object Set WshShell = CreateObject("Wscript.Shell") WshShell.RegWrite "HKCU\Software\Microsoft\VBA\Security\LoadControlsInForms", 1, "REG_DWORD" Set WshShell = Nothing End Sub ■ComboBox控件 '设置窗体ComboBox控件是否允许输入数据 ①属性Style 0-fmStyleDropDownCombo (可以) 2-fmStyleDropDownList（不可以） ②ComboBox.Clear 清除所有Item ■ComboBox使用示例 Private Sub UserForm_Initialize() ComboBox1.AddItem("Left Top") 'ListIndex = 0 ComboBox1.AddItem("Left Center") 'ListIndex = 1 ComboBox1.AddItem("Left Bottom") 'ListIndex = 2 ComboBox1.AddItem("Right Top") 'ListIndex = 3 ComboBox1.AddItem("Right Center") 'ListIndex = 4 ComboBox1.AddItem("Right Bottom") 'ListIndex = 5 ComboBox1.AddItem("Above Left") 'ListIndex = 6 ComboBox1.AddItem("Above Center") 'ListIndex = 7 ComboBox1.AddItem("Above Right") 'ListIndex = 8 ComboBox1.AddItem("Below Left") 'ListIndex = 9 ComboBox1.AddItem("Below Center") 'ListIndex = 10 ComboBox1.AddItem("Below Right") 'ListIndex = 11 ComboBox1.AddItem("Centered") 'ListIndex = 12 '使用下拉列表 ComboBox1.Style = fmStyleDropDownList '组合框值是ListIndex 值 ComboBox1.BoundColumn = 0 '把组合框设置为第一个条目 ComboBox1.ListIndex = 0 ComboBox1.Left = 18 ComboBox1.Top = 36 ComboBox1.Width = 90 ComboBox1.ListWidth = 90 '初始化CommandButton1 CommandButton1.Left = 230 CommandButton1.Top = 36 CommandButton1.Height = 120 CommandButton1.Width = 120 CommandButton1.Picture = LoadPicture("C:\windows\argyle.bmp") CommandButton1.PicturePosition = ComboBox1.Value EndSub PrivateSub ComboBox1_Click() SelectCase ComboBox1.Value Case 0 '上左 CommandButton1.Caption = "Left Top" CommandButton1.PicturePosition = fmPicturePositionLeftTop Case 1 '中左 CommandButton1.Caption = "Left Center" CommandButton1.PicturePosition = fmPicturePositionLeftCenter Case 2 '下左 CommandButton1.Caption = "Left Bottom" CommandButton1.PicturePosition = fmPicturePositionLeftBottom Case 3 '上右 CommandButton1.Caption = "Right Top" CommandButton1.PicturePosition = fmPicturePositionRightTop Case 4 '中右 CommandButton1.Caption = "Right Center" CommandButton1.PicturePosition = fmPicturePositionRightCenter Case 5 '下右 CommandButton1.Caption = "Right Bottom" CommandButton1.PicturePosition = fmPicturePositionRightBottom CommandButton1.Caption = "Above Left" CommandButton1.PicturePosition = fmPicturePositionAboveLeft Case 7 '中上 CommandButton1.Caption = "Above Center" CommandButton1.PicturePosition = fmPicturePositionAboveCenter Case 8 '右上 CommandButton1.Caption = "Above Right" CommandButton1.PicturePosition = fmPicturePositionAboveRight Case 9 '左下 CommandButton1.Caption = "Below Left" CommandButton1.PicturePosition = fmPicturePositionBelowLeft Case 10 '中下 CommandButton1.Caption = "Below Center" CommandButton1.PicturePosition = fmPicturePositionBelowCenter Case 11 '右下 CommandButton1.Caption = "Below Right" CommandButton1.PicturePosition = fmPicturePositionBelowRight Case 12 '中 CommandButton1.Caption = "Centered" CommandButton1.PicturePosition = fmPicturePositionCenter EndSelect EndSub ■ComboBox工作表控件的数据来源 ①LinkCell属性：当前显示的值 ②ListFillRange属性：数据来源 ■TextBox工作表控件 设置对齐方式：①Selection Margin②TextAlign ■TextBox自动选中文字 在MouseDown事件中写入代码： TextBox.SelStart=0 TextBox.SelLengh=Len(TextBox.Text) ■TextBox自动换行 设置两个属性：①WordWrop②MultiLine ■TextBox按回车键换行 属性：EnterKeyBehavior=true ■TextBox事件 TextBox_AfterUpdate '在焦点离开控件时发生 ■TabStrip分页控件的添加方法 Microsoft Window Common Controls 6.0 ■Common Dialog通用对话框控件 附加控件→Microsoft Common Dialog Control,version 6.0(SP6) ■打开对话框 Appliction.Dialogs(xlDialogOpen).Show '弹出【打开】对话框 Set BookSource = ActiveWorkbook If https://www.wendangku.net/doc/5f16088579.html, = https://www.wendangku.net/doc/5f16088579.html, Then Exit Sub ■另存为对话框 S = Appliction.GetSaveAsFilename '弹出【另存为】对话框 ■动态控件 Dim ABC As MSForms.CheckBox Set ABC = Me.Controls.Add("Forms.CheckBox.1","CheckBox1",True) '增加文本框 ABC.Caption="复选框" 注：定义数据类型用MSForms 但是Controls.Add控件用Forms 扩展：复选框 Forms.CheckBox.1 组合框 https://www.wendangku.net/doc/5f16088579.html,boBox.1 命令按钮 https://www.wendangku.net/doc/5f16088579.html,mandButton.1 标签 https://www.wendangku.net/doc/5f16088579.html,bel.1 框架 Forms.Frame.1 图像 Forms.Image.1 文本框 Forms.TextBox.1 列表框 Forms.ListBox.1 框架 Forms.MultiPage.1 选项按钮 Forms.OptionButton.1 滚动条 Forms.ScrollBar.1 数值调节钮 Forms.SpinButton.1 TabStrip Forms.TabStrip.1 切换按钮 Forms.ToggleButton.1 ■MultiPage动态增加删除控件 默认属性是Value,默认事件是Change Dim ABC As Control Set ABC = Multipage1.Pages(0).Controls.Add("Forms.TextBox.1","MyABC",True) '增加文本框 MultiPage1.Pages(0).Controls.Clear '删除文本框 If MultiPage1.Pages(0).Controls.Count > 0 Then '移去文本框 MultiPage1.Pages(0).Controls.Remove "ABC" End If ■在Sheet动态插入命令按纽 Dim i As Long, myShape For i = 1 to 30 Set myShape = Worksheets(1).Shapes.AddFormControl(xlButtonControl, 10, 50 * i, 100, 20) myShape.TextFrame.Characters.Text = "按钮"& i Next i ■动态创建控件，并添加代码 当一个窗口运行时，点击该窗口上的相关控件，则会自动新建一个表，并在表中自动添加一个命令按钮，将其命令按钮上Caption设置为"分析"，然后，在点击该命令则指定到相关宏运行相关代码: Sub Add_Sht_Cmb_Code() Application.ScreenUpdating = False https://www.wendangku.net/doc/5f16088579.html, = "数据分析" '增加一个工作表 ActiveSheet.OLEObjects.Add(ClAssType:="https://www.wendangku.net/doc/5f16088579.html,mandButton.1").Select With ThisWorkbook.VBProject.VBComponents(Sheets("数据分析") .CodeName).CodeModule .InsertLines(1, "") .InsertLines(2, "Private Sub CommandButton1_Click()") .InsertLines(3, " Application.ScreenUpdating = False") .InsertLines(5, " Rows(4).RowHeight = 14.25") .InsertLines(6, " Activesheet.Cells.Select") .InsertLines(7, " Selection.EntireColumn.Hidden = False ") .InsertLines(8, " Msgbox "& Chr(34) &" 添加代码成功！"& Chr(34)) 'Chr(34)表示双引号 .InsertLines(9, "End Sub") .InsertLines(10, "Private Sub Worksheet_Activate()") .InsertLines(11, " https://www.wendangku.net/doc/5f16088579.html,mandButton1.Caption = "& Chr(34) &" 分析 "& Chr(34)) .InsertLines(12, "https://www.wendangku.net/doc/5f16088579.html,mandButton1.AutoSize = True") .InsertLines(13, "End Sub") .InsertLines(14, "") End With Sheet1.Activate : Sheets("数据分析").Activate Msgbox("添加代码成功！") End Sub ■动态创建控件，并指定宏 Dim SheetX As worksheet Set SheetX = Sheets.Add '创建新表 https://www.wendangku.net/doc/5f16088579.html, = "数据分析"'命名新表 ActiveSheet.Buttons.Add(242.25, 26.25, 59.25, 22.5).Select '创建按钮 Selection.Text = "分析"'按钮改名 Selection.OnAction = "FENXI"'设置按钮执行的宏名称 ■Sheet中动态创建ComboBox控件 在单元格A2中添加一个Combobox并使其尺寸大小与单元格的大小相同 ActiveSheet.Shapes.AddOLEObject Left:=Cells(2, 1).Left, Top:=Cells(2, 1).Top, Width:=Cells(2, 1).Width, Height:= Cells(2, 1).Height,ClAssType:="https://www.wendangku.net/doc/5f16088579.html,boBox.1" 用Shapes.AddFormControl刚好没有ComboBox控件, 很奇怪. 所以要用AddOLEObject ■Sheet中动态添加按钮控件和事件处理代码 Sub MakeButton() Dim WSheet As Worksheet, MyNewbtn As OLEObject Dim Target As Range, ShtCodeName As String WSheet = Worksheets.Add(After:=ActiveSheet) https://www.wendangku.net/doc/5f16088579.html, = "新表" Target = Cells(15, 7) MyNewbtn = WSheet.OLEObjects.Add(ClassType:="https://www.wendangku.net/doc/5f16088579.html,mandButton.1", Link:=False, DisplayAsIcon:=False, Left:=Target.Left, Top:=Target.Top, Width:=92.25, Height:=30) https://www.wendangku.net/doc/5f16088579.html, = "MyNewButton"'设置按钮名 MyNewbtn.Object.Caption = "我的按钮"'设置按钮标题 ShtCodeName = WSheet.CodeName 也可以是：ShtCodeName = ThisWorkbook.Worksheets("新表").CodeName 向新表中添加事件: (1)添加事情的程序名一定要与添加的按钮名称对应 (2)如果出现"不信任到Visual Basic Project 的程序连接"的错误，解决方法为： 打开Excel－》工具－》宏－》安全性－》可靠发行商，选中"信任对于Visiual BAsic 项目的访问"，按确定即可。 With ThisWorkbook.VBProject.VBComponents. Item(ShtCodeName).CodeModule() .InsertLines(1, "Private Sub MyNewButton_Click()") .InsertLines(2, "msgbox ""生成事件成功""") .InsertLines(3, "'这是一个注释示例") .InsertLines(5, "End Sub") End With End Sub ■文本框右键弹出菜单 Private Sub TextBox1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) OnErrorResumeNext If Button = 2 Then OnErrorResumeNext https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars.Add "dddd", msoBarPopup, False, True https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Controls.Add(msoControlButton) https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Controls(1).Caption = "剪切" https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Controls(1).FaceId = 21 https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Controls(1).OnAction = "cut2" https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Controls.Add(msoControlButton) https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Controls(2).Caption = "复制" https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Controls(2).FaceId = 19 https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Controls(2).OnAction = "copy2" https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Controls.Add(msoControlButton) https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Controls(3).Caption = "粘贴" https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Controls(3).FaceId = 22 https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").Controls(3).OnAction = "pt" https://www.wendangku.net/doc/5f16088579.html,mandBars("dddd").showPopup End If End Sub ■控件右键弹出菜单 Private Sub TextBox摘要_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single) If Button = xlSecondaryButton Then'或：Button = 2 ShowBar End If End Sub Sub ShowBar() Dim oCmdBar As CommandBar Dim oCtrl As CommandBarControl On Error Resume Next CommandBars("txtBar").Delete On Error GoTo 0 Set oCmdBar = CommandBars.Add(Name:="txtBar", Position:=msoBarPopup, Temporary:=True) With oCmdBar Set oCtrl = .Controls.Add(Type:=msoControlButton) With oCtrl .Caption = "复制" .OnAction = "复制" End With Set oCtrl = .Controls.Add(Type:=msoControlButton) With oCtrl .Caption = "粘贴" .OnAction = "粘贴" End With Set oCtrl = .Controls.Add(Type:=msoControlButton) With oCtrl .Caption = "删除" .OnAction = "删除" End With End With oCmdBar.ShowPopup End Sub Sub 复制() Application.SendKeys "^c", True End Sub Sub 剪切() Application.SendKeys "^x", True End Sub Sub 粘贴() Application.SendKeys "^v", True End Sub Sub 删除() Application.SendKeys "{del}", True End Sub ■窗体右键弹出菜单 PrivateSub UserForm_MouseUp(ByVal Button AsInteger, ByVal Shift AsInteger, ByVal X AsSingle, ByVal Y AsSingle) If Button = 2 Then Dim oCmdBar As CommandBar Dim oCtrl As CommandBarControl OnErrorResumeNext CommandBars("txtBar").Delete() OnErrorGoTo 0 oCmdBar = CommandBars.Add(Name:="txtBar", Position:=msoBarPopup, Temporary:=True) With oCmdBar oCtrl = .Controls.Add(Type:=msoControlButton) With oCtrl .Caption = "设置账本为：普通账本█" .Enabled = False .OnAction = "设置账本为_普通账本" oCtrl = .Controls.Add(Type:=msoControlButton) With oCtrl .Caption = "设置账本为：会计核算中心资金账本█" .OnAction = "设置账本为_会计核算中心资金账本" EndWith EndWith oCmdBar.ShowPopup() EndIf EndSub ■工作表右键菜单 Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Dim x As CommandBarButton, n As Long https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Reset '先恢复右键 n = n + 1 Set x = https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls.Add(Type:=msoControlButton, Before:= n) '插入位置 x.Caption = "右键标题"'名称 x.FaceId = 59 '图标 x.OnAction = "被调用的函数"'宏 EndSub PrivateSub Worksheet_Deactivate() '工作表转非活动状态时 OnErrorResumeNext https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("表2按钮").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Reset '恢复 https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("删除(&D)...").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("插入(&I)...").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("选择性粘贴(&S)...").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("清除内容(&N)").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("插入批注(&M)").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("从下拉列表中选择(&K)...").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("添加监视点(&W)").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("创建列表(&C)...").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("超链接(&H)...").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("查阅(&L)...").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("筛选(&E)").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("排序(&O)").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("显示拼音字段(&S)").Delete https://www.wendangku.net/doc/5f16088579.html,mandBars("cell").Controls("命名单元格区域(&R)...").Delete EndSub ■特殊的右键菜单 ◆仅在A列出现数据菜单： Thisworkbook代码： Private Sub Workbook_Deactivate() Call DeleteMycell End Sub Sheet1 代码： Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) If Target.Column = 1 Then Call Mycell https://www.wendangku.net/doc/5f16088579.html,mandBars("Mycell").ShowPopup Cancel = True End If End Sub 模块代码： Sub Mycell() Dim arr As Variant，i As Integer Dim Mycell As CommandBar OnError Resume Next https://www.wendangku.net/doc/5f16088579.html,mandBars("Mycell").Delete arr = Array("经理室", "办公室", "生技科", "财务科", "营业部") Set Mycell = https://www.wendangku.net/doc/5f16088579.html,mandBars.Add("Mycell", 5) For i = 0 To 4 With Mycell.Controls.Add(1) .Caption = arr(i) .OnAction = "MyOnAction" End With Next i End Sub Sub MyOnAction() ActiveCell = https://www.wendangku.net/doc/5f16088579.html,mandBars.ActionControl.Caption End Sub Sub DeleteMycell() On Error Resume Next https://www.wendangku.net/doc/5f16088579.html,mandBars("Mycell").Delete End Sub ◆改变整个右键菜单代码： ThisWrokbook： Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Call Mycell https://www.wendangku.net/doc/5f16088579.html,mandBars("Mycell").ShowPopup Cancel = True End Sub Sheet1里： Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean) Call Mycell https://www.wendangku.net/doc/5f16088579.html,mandBars("Mycell").ShowPopup Cancel = True 模块： Sub Mycell() With https://www.wendangku.net/doc/5f16088579.html,mandBars.Add("Mycell", msoBarPopup) With .Controls.Add(Type:=msoControlButton) .Caption = "会计凭证" .FaceId = 9893 .OnAction = "Test" End With With .Controls.Add(Type:=msoControlButton) .Caption = "会计账簿" .FaceId = 284 End With With .Controls.Add(Type:=msoControlPopup) .Caption = "会计报表" With .Controls.Add(Type:=msoControlButton) .Caption = "月报" .FaceId = 9590 End With With .Controls.Add(Type:=msoControlButton) .Caption = "季报" .FaceId = 9591 End With With .Controls.Add(Type:=msoControlButton) .Caption = "年报" .FaceId = 9592 End With End With With .Controls.Add(Type:=msoControlButton) .Caption = "凭证打印" .FaceId = 9614 .BeginGroup = True End With With .Controls.Add(Type:=msoControlButton) .Caption = "账簿打印" .FaceId = 707 End With With .Controls.Add(Type:=msoControlButton) .Caption = "报表打印" .FaceId = 986 End With End With End Sub Sub DeleteMycell() On Error Resume Next https://www.wendangku.net/doc/5f16088579.html,mandBars("Mycell").Delete End Sub ◆禁用鼠标右键： ThisWorkbook里： Private Sub Workbook_Deactivate() Call EnaBar End Sub 模块： Sub DisBar() Dim myBar As CommandBar For Each myBar In CommandBars If myBar.Type = msoBarTypePopup Then myBar.Enabled = False End If Next End Sub Sub EnaBar() Dim myBar As CommandBar For Each myBar In CommandBars If myBar.Type = msoBarTypePopup Then myBar.Enabled = True End If Next End Sub 在Sheet中定义2个Command分别指定宏，可实现禁用与启用。 ■Sheet控件跟随当前选中的单元格移动 Private Sub Worksheet_SelectionChange(ByVal Target As Range) TextBox1.Visible = True TextBox1.Top = Target.Top TextBox1.Left = Target.Left + Target.Width TextBox1.Value = "" TextBox1.WordWrap = False TextBox1.AutoSize = True End Sub ■窗体启动时的位置 1.必须先将属性StartUpPosition 设置为 0-手动 2.下面3个代码都可以调节窗体位置→Form.Left = 100; Form.Top = 150; Form.Move()函数 《API函数》 ■VBA调用VC的动态链接库Dll Private Declare Function TestVC Lib "D:\桌面\My.dll" (ByVal a AsLong, ByVal b AsLong) AsLong Sub调用VCDll() Dim c AsLong c = TestVC(12, 13) ◆获取桌面所在路径 PrivateDeclareFunction SHGetSpecialFolderLocation Lib"shell32.dll"(ByVal hwndOwner AsLong, ByVal nFolder AsLong, ByVal pidl As ITEMIDLIST) AsLong PrivateDeclareFunction SHGetPathFromIDList Lib"shell32.dll"Alias"SHGetPathFromIDListA"(ByVal pidl AsLong, ByVal pszPath AsString) AsLong Private Type SHITEMID CB AsLong abID AsByte End Type Private Type ITEMIDLIST mkid As SHITEMID End Type Function GetDeskTop() AsString Dim R AsLong, Path AsString Dim IDL As ITEMIDLIST R = SHGetSpecialFolderLocation(100, 0, IDL) If R = 0Then Path = Space(255) R = SHGetPathFromIDList(ByVal IDL.mkid.CB, ByVal Path) R = InStr(Path, vbNullChar) If R >0Then Path = Left(Path, R - 1) EndIf Else Path = "" EndIf GetDeskTop = Path EndFunction ■Sleep Public Declare Sub Sleep Lib "kernel32 " (ByVal dwMilliseconds AsLong) Sleep 1000 '程序暂停1000毫秒 ■定时器SetTimer和KillTimer Private Declare FunctionSet Timer Lib "user32.dll" (ByVal hwnd AsLong, ByVal nIDEvent AsLong, ByVal uElapse AsLong, ByVal lpTimerFunc AsLong) AsLong Private Declare Function KillTimer Lib "user32.dll" (ByVal hwnd AsLong, ByVal nIDEvent AsLong) AsLong Public TimerID AsLong '声明lTimerID用于存放定时器的ID Private n AsLong '启动定时器，uElapse是定时器触发的时间，单位为毫秒 Sub StartTimer(uElapse AsLong) '如果定时器不存在，则设置定时器，定时器触发的时间为uElapse，定时器触发后执行OnTime If TimerID = 0 Then TimerID = Set Timer(0, 0, uElapse, AddressOf OnTime) '否则停止定时器，并设置一个新的定时器 Else Call StopTimer TimerID = Set Timer(0, 0, uElapse, AddressOf OnTime) EndIf EndSub '停止定时器的函数 Sub StopTimer() Call KillTimer(0, TimerID) EndSub 'OnTime函数 Sub OnTime() ' 计时器触发后运行的代码放在这 n = n + 1 Cells(2, 2) = For mat(Now, "hh:mm:ss") If n > 10 Then Call KillTimer(0, TimerID) EndIf EndSub Sub启动定时器() n = 0 Call StartTimer(1000) EndSub ◆GetWindowRect32 PrivateDeclare Function GetWindowRect32 Lib "user32" Alias "GetWindowRect" (ByVal hWnd AsLong, lpRect As typRect32) AsLong 注：Type typRect32 Left AsLong Top AsLong Right AsLong Bottom AsLong End Type 其中：返回值一般没有用，参见下面。该函数主要用于取得lpRect参数的矩形左上角和右下角2个点的坐标 扩展： 函数原型：BOOL GetWindowRect（HWND hWnd，LPRECTlpRect） hWnd:窗口句柄。 lpRect：指向一个RECT结构的指针，该结构接收窗口的左上角和右下角的屏幕坐标。 ■WindowFromPoint Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint AsLong, ByVal yPoint AsLong) AsLong 功能：通过指定点坐标(xPoint,yPoint),获取该点所在的窗口句柄 C语言函数原型：HWND WindowFromPoint（POINT Point）； 参数：Point：指定一个被检测的点的POINT结构。 返回值S：返回值为包含该点的窗口的句柄。如果包含指定点的窗口不存在，返回值为NULL。如果该点在静态文本控制之上，返回值是在该静态文本控制的下面的窗口。备注：WindowFromPoint函数不获取隐藏或禁止的窗口句柄，即使点在该窗口内。应用程序应该使用ChildWindowFromPoint函数进行无限制查询。 ■GetCursorPos() Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) AsLong 功能：获取鼠标当前位置的坐标，lpPoint C语言函数原型：BOOL GetCursorPos（LPPOlNT IpPoint）； 参数：IpPint：POINT结构指针，该结构接收光标的屏幕坐标。 返回值：如果成功，返回值非零；如果失败，返回值为零。若想获得更多错误信息，请调用GetLastError函数。 备注：光标的位置通常以屏幕坐标的形式给出，它并不受包含该光标的窗口的映射模式的影响。该调用过程必须具有对窗口站的WINSTA_READATTRIBUTES 访问权限。 ◆GetSystemMetrics获取屏幕分辩率 PublicDeclareFunction GetSystemMetrics Lib"user32" (ByVal nIndex AsLong) AsLong ActiveWindow.Zoom = 133 * (GetSystemMetrics(0) * GetSystemMetrics(1)) / 1440 / 900 ■设置工作表中TextBox的内容和格式 ActiveSheet.Shapes("TextBox1").Select Selection.Characters.Text="记账凭证"&Chr(10)&"分类号" With Selection.Characters(Start:=2,Length:=3).Font .Name="宋体" .Size=9 .Underline=xlUnderlineStyleSingle EndWith 《文件操作》 FSO文件操作 ■FSO文件操作理论 在Scripting 类型库 (Scrrun.Dll)中，它同时包含了Drive、Folder、File、FileSystemObject和TextStream五个对象。 前期绑定：引用 "Microsoft Scripting Runtime" Dim fso As NewFileSystemObject Dim drive As Drive 后期绑定：(直接使用下行代码) Dim fso AsObject, drive As Object Set fso = CreateObject("Scripting.FileSystemObject") Set drive = fso.GetDrive("C:\") ■Drive对象示例 Dim fso AsObject, drive AsObject, sReturn As String Set fso = CreateObject("Scripting.FileSystemObject") Set drive = fso.GetDrive("C:\") sReturn = drive.VolumeName '返回C盘名字= "系统盘" sReturn = drive.TotalSize '返回C盘大小(字节) = "157********" sReturn = drive.FreeSpace 'C盘可用空间大小(字节) = "9623265280" sReturn = drive.FileSystem '返回C盘的文件系统= "NTFS" sReturn = drive.AvailableSpace 'C盘可用空间大小(字节) = "9623265280" sReturn = drive.DriveLetter '返回C盘的字母(只读) = "C" sReturn = drive.DriveType '返回磁盘类型= "2" sReturn = drive.IsReady '确定指定的驱动器是否准备好= "True" sReturn = drive.Path '返回指定文件、文件夹、或驱动器的路径= "C:" sReturn = drive.RootFolder '返回根目录文件夹。只读属性= "C:\" sReturn = drive.SerialNumber '返回用于唯一标识磁盘卷标的十进制序列号= "1442939195" sReturn = drive.ShareName'返回指定驱动器的网络共享名= "" ■FileSystemObject示例 ■FSO文件夹 Dim fso AsNew FileSystemObject, sReturn AsString, b AsBoolean fd = fso.CreateFolder("D:\桌面\软件") '创建一个文件夹= "D:\桌面\软件" fso.DeleteFolder("D:\桌面\软件", True) '删除一个文件夹(=True 强行删除) fso.CopyFolder("D:\桌面\软件", "C:\软件") '将"D:\软件"复制至"C:\软件" fso.MoveFolder("D:\桌面\1", "C:\") '移动一个文件夹(错误：拒绝的权限) sReturn = fso.GetParentFolderName("D:\桌面\软件") '找出一个文件夹的父文件夹的名称= "D:\桌面" b = fso.FileExists("C:\test.txt") '检测文件是否存在 b = fso.FolderExists("D:\桌面\同田乡") '检测文件夹是否存在 Dim fd As folder fd = fso.GetFolder("D:\桌面\软件") '获得已有Folder对象的一个实例 fd.Copy("C:\软件", True) '将"D:\软件"复制至"C:\软件"(=True 覆盖) fd.Move("C:\软件") '移动一个文件夹(错误：拒绝的权限) fd.Delete(True) '删除一个文件夹fd (=True 强行删除) ■实例：FSO遍历文件夹 Sub总函数() '■打开文件对话框，用户自己选择目录：Path Application.DisplayAlerts = False Dim fd As FileDialog, Path AsString Set fd = Application.FileDialog(msoFileDialogFolderPicker) If fd.Show = -1 Then Else ExitSub EndIf '■遍历该文件夹Path内所有的文件 Call遍历文件夹(Path) Application.DisplayAlerts = True EndSub Sub遍历文件夹(Path AsString) Dim fso AsObject, folder AsObject, S AsString Set fso = CreateObject("Scripting.FilesyStemObject") Call遍历文件(Path) ForEach folder In fso.getfolder(Path).SubFolders Call遍历文件夹(Path &"\"& https://www.wendangku.net/doc/5f16088579.html,) Next Set fso = Nothing EndSub Sub遍历文件(Path AsString) Dim fso AsObject, f AsObject, S AsString, FileName AsString Set fso = CreateObject("Scripting.FilesyStemObject") ForEach f In fso.getfolder(Path).Files FileName = https://www.wendangku.net/doc/5f16088579.html, Call处理某一个文件(Path &"\"& FileName) Next Set fso = Nothing EndSub PrivateSub CmdRead_Click() Dim fso AsNew FileSystemObject, file1 As File, ts As TextStream, s AsString file1 = fso.GetFile("C:\testfile.txt") ts = file1.OpenAsTextStream(ForReading) '读取一行 s = ts.ReadLine MsgBox(s) ts.Close EndSub PrivateSub CmdWrite_Click() Dim txtfile As File, ts As TextStream txtfile = fso.GetFile("c:\testfile.txt") ts = txtfile.OpenAsTextStream(ForWriting) '使用Write方法写入一行。 ts.Write("This is only a Test") ' 写入一行带有换行符的文本。 ts.WriteLine("Testing 1, 2, 3.") ' 向文件中写入三个换行符。 ts.WriteBlankLines(3) ts.Close() EndSub ■FSO读文件 Sub读取文件() Const ForReading = 1, ForWriting = 2 Dim fso As New FileSystemObject, ts As TextStream Dim str(1 To 10000) As String '■获取总行数 Set ts = fso.OpenTextFile("D:\桌面\Excel2003.cpp", 8) n = ts.Line '■开始读取(按行) Set ts = fso.OpenTextFile("D:\桌面\Excel2003.cpp", 1) For i = 1 To n str(i) = ts.ReadLine '读取一行(指针自动移至下一行) Next i ts.Close End Sub Sub 按行读取文件存入数组() '■按行读取"D:\桌面\AlertCfg.ini"文件，并按行存入数组A（）中 Dim A(), i AsLong, fso, n AsLong Set fso = CreateObject("Scripting.FileSystemObject") n = fso.OpenTextFile("D:\桌面\AlertCfg.ini", 8).Line '读取文件总行数ReDim A(n) i = 0 Open"D:\桌面\AlertCfg.ini"For InputAs #1 Do While Not EOF(1) '循环至文件尾 i = i + 1 Line Input #1, A(i) '读入一行数据并将其赋予某变量 Loop Close #1 End Sub ■FSO写文件 Sub写入现有文件() Dim fso As New FileSystemObject, f As File, ts As TextStream Set f = fso.GetFile("C:\testfile.txt") ts = f.OpenAsTextStream(ForWriting) '以写入的模式打开文件 ts.Write("This is only a Test") '使用Write方法写入一行。 ts.WriteLine("Testing 1, 2, 3.")'写入一行带有换行符的文本。 ts.WriteBlankLines(3)'向文件中写入三个换行符。 ts.Close EndSub Sub写入现有文件() Set ts = fso.OpenTextFile("C:\testfile.txt", ForWriting) '以写入的模式打开文件 ts.Write("This is only a Test") '使用Write方法写入一行。 ts.WriteLine("Testing 1, 2, 3.")'写入一行带有换行符的文本。 ts.WriteBlankLines(3)'向文件中写入三个换行符。 ts.Close EndSub Sub写入创建文件() Dim fso As New FileSystemObject, f As File, ts As TextStream Set f = fso.CreateTextFile("C:\testfile.txt", True) '创建文件 ts = f.OpenAsTextStream(ForWriting) '以写入的模式打开文件 ts.Write("This is only a Test") '使用Write方法写入一行。 ts.WriteLine("Testing 1, 2, 3.")'写入一行带有换行符的文本。 ts.WriteBlankLines(3)'向文件中写入三个换行符。 ts.Close EndSub ■VBA文件操作 ■VBA读写文件 Sub 按行读取文件存入数组() '■按行读取"D:\桌面\AlertCfg.ini"文件，并按行存入数组A（）中 Dim A(), i AsLong, fso, n AsLong Set fso = CreateObject("Scripting.FileSystemObject") n = fso.OpenTextFile("D:\桌面\AlertCfg.ini", 8).Line '读取文件总行数 ReDim A(n) i = 0 Open"D:\桌面\AlertCfg.ini"For InputAs #1 Do While Not EOF(1) '循环至文件尾 i = i + 1 Line Input #1, A(i) '读入一行数据并将其赋予某变量 Loop Close #1 End Sub Sub WriteToTextFile(ErrorMessage As String, txtFile As String) '打开文本文件，写入数据 Open txtFile For Append As #1 Print #1, ErrorMessage Close #1 End Sub ●函数EOF(filenumber) 示例：EOF(1) = True '其中参数1是文件号#1 EOF(1) = True 表示"已经到文件末尾" ●函数LOF(filenumber) 与函数LOC(filenumber) LOF功能：返回一个Long，表示用Open语句打开的文件的大小，该大小以字节为单位。 LOC功能：返回一个Long，在已打开的文件中指定当前读/写位置。 示例：Do While MyLocation < LOF(1) ' 循环至文件尾 MyLocation = Loc(1) ' 取得当前位置 ●Line Input #1, str 功能：读取文件号为#1的一行数据并将其赋予某变量str ●Open "D:\桌面\AlertCfg.ini" For Append As #1 Input：以读取方式打开。 Output：以写入方式打开。 Append：以追加方式，即添加内容到文件末尾打开。 Binary：以二进制方式打开。 Random：以随机方式打开，如果未指定方式，则以 Random 方式打开文件 ●Write # 语句 语法：Write #filenumber, [outputlist] 功能：将数据写入顺序文件。 如果省略 outputlist，并在 filenumber 之后加上一个逗号，则会将一个空白行打印到文件中。 多个表达式之间可用空白、分号或逗号隔开。空白和分号等效。 与 Print # 语句不同，当要将数据写入文件时，Write # 语句会在项目和用来标记字符串的引号之间插入逗号。 ●Print # 语句 语法：Print #filenumber, [outputlist] outputlist 参数的设置：[{Spc(n) | Tab[(n)]}] [expression] [charpos] Spc(n) 用来在输出数据中插入空白字符，而 n 指的是要插入的空白字符数。 Tab(n) 用来将插入点定位在某一绝对列号上，这里，n 是列号。使用无参数的 Tab 将插入点定位在下一个打印区的起始位置。 expression 要打印的数值表达式或字符串表达式。 charpos 指定下一个字符的插入点。使用分号将插入点定位在上一个显示字符之后。用 Tab(n) 将 插入点定位在某一绝对的列号上，用无参数的 Tab 将插入点定位在下一个打印区的起始处。如果省略charpos，则在下一行打印下一个字符。Open "F:\test.txt" For Output As #1 ' 打开输出文件。 Print #1, "This is a test" ' 将文本数据写入文件。 Print #1, ' 将空白行写入文件。 Print #1, "Zone 1"; Tab; "Zone 2" ' 数据写入两个区（print zones）。 Print #1, "Hello"; " "; "World" ' 以空格隔开两个字符串。 Print #1, Spc(5); "5 leading spaces " ' 在字符串之前写入五个空格。 Print #1, Tab(10); "Hello" ' 将数据写在第十列 ■打开文件 Workbooks.Open("学生表.xls") Workbooks.Open("D:\学生表.xls") Workbooks.Open FileName:= "学生表.xls" 打开Text和Access文件，将Open换成OpenText OpenDatabase ■当前驱动器、路径 S = CurDir返回当前路径；S=CurDir("C:") 返回C盘的当前路径 ChDrive "D:"改变当前驱动器ChDir "D:\安装"改变D盘当前路径 ■复制文件 FileCopy "C:\2.txt","D:\3.txt" '复制文件 ■复制、删除、重命名文件
- Excel-VBA-操作-Word(入门篇)
- VBA文件操作及目录操作
- VBA单元格操作
- VBA操作网页读取数据自动填入EXCEL表中
- 用VBA操作Word
- 在VBA中对名称的基本操作
- excel vba延时操作
- EXCEL VBA基础--单元格的操作
- VBA中的常用的几个操作操作
- VBA操作文本文件
- Excel VBA 操作 Word(入门篇)教学教材
- VBA操作VBA代码本身
- Excel VBA操作文件大全
- 等级考试vba操作题参考答案
- 使用VBA操作Word表格
- 【Excel】VBA中名称的使用
- Excle VBA 操作调用文件方法总结
- excelvba分类汇总Excel中用VBA操作文件的方法汇总
- Excel培训VBA操作数据库实例
- VBA使用手册