VBA常用对象属性、函数

Public Function NumtoCol(Number As Integer) As String '将数值转换为表格的列号Dim i1 As Integer, i2 As Integer, i3 As Integer
Dim s1 As String, s2 As String, s3 As String
i2 = Number \ 26
i3 = i2 \ 26 '第三位
i2 = i2 Mod 26 '第二位
i1 = Number Mod 26 '第一位
If i2 > 0 And i1 = 0 Then
i1 = 26
i2 = i2 - 1
End If
If i3 > 0 And i2 = 0 Then
i2 = 26
i3 = i3 - 1
End If
s3 = Chr(i3 + 64)
s2 = Chr(i2 + 64)
s1 = Chr(i1 + 64)
If s3 = "@" Then
If s2 = "@" Then
NumtoCol = s1
Else
NumtoCol = s2 & s1
End If
Else
NumtoCol = s3 & s2 & s1
End If
End Function
'处理日期
Sub 显示当前日期和时间()
MsgBox "当前日期和时间为：2008-02-08 " & Time
End Sub
Sub 日期运算()
Dim MyDate As Date
MyDate = Date
Debug.Print "当前日期：" & MyDate '当前日期
Debug.Print "10天后的日期：" & MyDate + 10 '返回10天后的日期
Debug.Print "10天前的日期：" & MyDate - 10 '返回10天前的日期
End Sub
Sub 增加日期指定部分的值()
Dim MyDate As Date
MyDate = "31-Jan-2008"
Debug.Print "当前日期：" & MyDate
Debug.Print "前10天的日期：" & DateAdd("d", -10, MyDate)
Debug.Print "后10天的日期：" & DateAdd("d", 10, MyDate)
Debug.Print "下周同星期数的日期：" & DateAdd("ww", 1, MyDate)
Debug.Print "明年的今日：" & DateAdd("yyyy", 1, MyDate)
End Sub
Sub 距奥运会开幕日期()
Dim oDate As Date, today As Date
Dim t1 As Integer, t2 As Integer
oDate = #8/8/2008#
today = #2/8/2008#
t1 = DateDiff("d", today, oDate)
t2 = DateDiff("ww", today, oDate)
MsgBox "今日距北京奥运会开幕还有：" & t1 & "天（" & t2 & "周）！" End Sub
Sub 暂停程序的执行()
Dim PauseTime, start, Finish, TotalTime
If (MsgBox("是否暂停程序5秒钟", vbQuestion + vbYesNo)) = vbYes Then PauseTime = 5 ' 设置暂停时间。

start = Timer ' 设置开始暂停的时刻。

Do While Timer < start + PauseTime
DoEvents ' 将控制让给其他程序。

Loop
Finish = Timer ' 设置结束时刻。

TotalTime = Finish - start ' 计算总时间。

MsgBox "程序暂停时间为：" & TotalTime & " 秒！"
Else
End
End If
End Sub
'处理字符串
Type CustomerRecord ' 定义用户自定义的数据类型
ID As Integer ' 将此定义放在常规模块中
Name As String * 10
Address As String * 30
End Type
Sub 获取自定义类型字节()
Dim Customer As CustomerRecord ' 声明变量
mylen = Len(Customer) ' 返回 42
MsgBox "自定义类型CustomerRecord所占用的字节为：" & mylen
End Sub
Sub 用循环生成重复字符串()
Dim s As String
For i = 1 To 10
s = s & "_"
Next
Debug.Print s
Sub 生成重复字符()
Debug.Print String(5, "*") ' 返回 "*****"
Debug.Print String(5, 42) ' 返回 "*****"
Debug.Print String(10, "ABC") ' 返回 "AAAAAAAAAA"
End Sub
Sub 生成重复空格()
Debug.Print "12345678901234567890"
Debug.Print "Hello" & Space(5) & "Excel VBA" '将5个空格插入两个字符串中间
End Sub
Sub 大小写字母转换()
Dim str1, strLower, strUpper
str1 = "Hello Excel 2007 VBA" ' 要输送的字符串
strLower = LCase(str1) ' 返回" hello excel 2007 vba"
strUpper = UCase(str1) ' 返回" HELLO EXCEL 2007 VBA"
Debug.Print strLower
Debug.Print strUpper
End Sub
Sub 字符转换()
Dim str1, strLower, strUpper, strProper
str1 = "Hello Excel 2007 VBA" ' 要输送的字符串
strLower = StrConv(str1, vbLowerCase) ' 返回" hello excel 2007 vba"
strUpper = StrConv(str1, vbUpperCase) ' 返回" HELLO EXCEL 2007 VBA "
strProper = StrConv(str1, vbProperCase) ' 返回" Hello excel 2007 vba "
Debug.Print strLower
Debug.Print strUpper
Debug.Print strProper
End Sub
Sub 查询字符编码()
Debug.Print "字符A的编码：" & Asc("A") ' 返回 65
Debug.Print "字符a的编码：" & Asc("a") ' 返回 97
Debug.Print "字符串Excel的编码：" & Asc("Excel") ' 返回 69
End Sub
Sub 生成字符()
Debug.Print "编码65对应的字母：" & Chr(65) ' 返回 A
Debug.Print "编码97对应的字母：" & Chr(97) ' 返回 a
Debug.Print "编码69对应的字母：" & Chr(69) ' 返回 E
Debug.Print "编码37对应的字母：" & Chr(37) ' 返回 %
End Sub
Sub 使用like比较字符串()
Debug.Print """aBBBa"" Like ""a*a""的结果为："; "aBBBa" Like "a*a" ' 返回 True"
Debug.Print """F"" Like ""[A-Z]""的结果为："; "F" Like "[A-Z]" ' 返回 True
Debug.Print """F"" Like ""[!A-Z]""的结果为："; "F" Like "[!A-Z]" ' 返回 False
Debug.Print """a2a"" Like ""a#a""的结果为："; "a2a" Like "a#a" ' 返回 True
Debug.Print """aM5b"" Like ""a[L-P]#[!c-e]""的结果为："; "aM5b" Like "a[L-P]#[!c-e]" ' Debug.Print """BAT123khg"" Like ""B?T*""的结果为："; "BAT123khg" Like "B?T*" ' 返回 T Debug.Print """CAT123khg"" Like ""B?T*""的结果为："; "CAT123khg" Like "B?T*" ' 返回 Fa
Sub 使用StrComp比较字符串()
Dim str1, str2, MyComp
str1 = "ABCD"
str2 = "abcd"
Debug.Print StrComp(str1, str2, 1) ' 返回 0
Debug.Print StrComp(str1, str2, 0) ' 返回 -1
Debug.Print StrComp(str2, str1) ' 返回 1
End Sub
Sub 取左侧子串()
Dim str1 As String
str1 = "Hello Excel 2007 VBA" ' 定义字符串
Debug.Print Left(str1, 1) ' 返回"A"
Debug.Print Left(str1, 7) ' 返回"Hello E"
Debug.Print Left(str1, 30) ' 返回"Hello Excel 2007 VBA"
End Sub
Sub 取右侧子串()
Dim str1 As String
str1 = "Hello Excel 2007 VBA" ' 定义字符串
Debug.Print Right(str1, 1) ' 返回"A"
Debug.Print Right(str1, 7) ' 返回"007 VBA "
Debug.Print Right(str1, 30) ' 返回"Hello Excel 2007 VBA"
End Sub
Sub 获取部分子串()
Dim str1 As String
str1 = "Hello Excel 2007 VBA" ' 定义字符串
Debug.Print Mid(str1, 1, 5) ' 返回"Hello"
Debug.Print Mid(str1, 7, 5) ' 返回"Excel"
Debug.Print Mid(str1, 7) ' 返回"Excel 2007 VBA"
End Sub
Sub 删除字符串两侧空格()
Dim str1 As String, str2 As String
str2 = "end" '用来定位属部空格的位置
str1 = " Hello Excel 2007 VBA " ' 定义字符串(首尾各有两个空格) Debug.Print "123456789012345678901234567890" '显示坐标
Debug.Print Trim(str1); str2
Debug.Print LTrim(str1); str2
Debug.Print RTrim(str1); str2
End Sub
Sub 搜索子串位置()
Dim str1 As String
str1 = "Hello Excel 2007 VBA"
Debug.Print InStr(str1, "e")
Debug.Print InStr(3, str1, "e")
Debug.Print InStr(3, str1, "e", vbTextCompare)
End Sub
'单元格值获取，设置
Sub 设置单元格的值()
Sheet1.Range("A1").Value = "测试"
End Sub
Sub 获取单元格的值()
Dim r
r = Sheet1.Range("A1").Value
MsgBox r
End Sub
Sub 清除单元格的值()
Sheet1.Range("A1").Clear
End Sub
'设置工作表标签
Sub 更改工作表标签()
= "第1张工作表"
End Sub
Sub 控制状态栏()
Dim i As Long
For i = 1 To ActiveSheet.rows.Count
If i Mod 100 = 0 Then
Application.StatusBar = "正在处理第 " & i & " 行的数据，请稍候！" End If
Next
Application.StatusBar = False
End Sub
Sub 控制编辑栏()
With Application
If .DisplayFormulaBar Then
.DisplayFormulaBar = False
Else
.DisplayFormulaBar = True
End If
End With
End Sub
Sub 显示鼠标指针形状()
Dim i As Integer
For i = 1 To 3
MsgBox "显示第 " & i & " 种鼠标指针形状！", vbInformation + vbOKOnly Application.Cursor = i
st = Timer
Do While Timer <= st + 5
DoEvents
Loop
MsgBox "恢复默认鼠标指针形状！", vbInformation + vbOKOnly
Application.Cursor = xlDefault
End Sub
Sub 屏幕更新()
Dim aTime(2)
Application.ScreenUpdating = True
For i = 1 To 2
If i = 2 Then Application.ScreenUpdating = False
Worksheets(i).Activate
starttime = Timer
For j = 1 To ActiveSheet.rows.Count
If j Mod 2 = 0 Then
rows(j).Hidden = True
End If
Next j
stopTime = Timer
aTime(i) = stopTime - starttime
Next i
Application.ScreenUpdating = True
MsgBox "打开屏幕更新,程序执行的时间: " & aTime(1) & " 秒" & Chr(13) & _ "关闭屏幕更新,程序执行的时间: " & aTime(2) & " 秒"
End Sub
Sub 删除工作表()
Application.DisplayAlerts = False
ActiveSheet.delete
Application.DisplayAlerts = True
End Sub
Sub 最近使用文档()
Dim i As Long, j As Long
Dim r As RecentFile
ActiveSheet.Columns(1).Clear
i = 1
For Each r In Application.RecentFiles
ActiveSheet.Cells(i, 1) =
i = i + 1
Next
End Sub
Sub 模似输入()
Dim dReturnValue As Double
dReturnValue = Shell("NOTEPAD.EXE", 1) '打开记事本
AppActivate dReturnValue '激活应用程序
Application.SendKeys "~", True
Application.SendKeys "Keybord input demo :", True
Application.SendKeys "~", True
Application.SendKeys " Excel 2007 VBA ! ", True
End Sub
Application.OnTime EarliestTime:=TimeSerial((Hour(Now) + 1) Mod 24, 0, 0), _
Procedure:="starttime"
MsgBox "现在时间是：" & Hour(Now) & " 点！"
End Sub
Sub endtime()
On Error Resume Next
Application.OnTime EarliestTime:=TimeSerial((Hour(Now) + 1) Mod 24, 0, 0), _
Procedure:="starttime", schedule:=False
End Sub
Sub 合并区域()
Worksheets("Sheet3").Activate
Set unRange = Application.Union(Range("A1:B5"), Range("D1:E5"))
unRange.Formula = "=RAND()"
End Sub
Sub 设置自定义功能键()
Application.OnKey "%.", "NextPage"
Application.OnKey "%,", "PrePage"
End Sub
Sub NextPage()
rgeScroll Down:=1
End Sub
Sub PrePage()
rgeScroll up:=1
End Sub
Sub 禁止自定义功能键()
Application.OnKey "%."
Application.OnKey "%,"
End Sub
Sub 查询股票价格()
Dim sStock As String, cPrice As Currency
sStock = InputBox(prompt:="输入股票代码:" & Chr(13) & " (例如:600000) ")
cPrice = Application.WorksheetFunction.VLookup(sStock, _
Worksheets("Sheet1").Range("A1:C5"), 3, 0)
MsgBox "股票" & sStock & "收盘价为：" & cPrice
End Sub
Sub 快速跳转()
Application.GoTo Reference:=Worksheets("Sheet2").Range("A1:A10"), Scroll:=True End Sub
'以下代码使用CountIf函数在指定区域生成不重复的随机数:
Sub 生成不重复随机数()
Dim rng As Range, rng1 As Range
Set rng = Application.InputBox(prompt:="选择要保存不重复随机数的单元格区域：", _
If rng Is Nothing Then Exit Sub
Randomize
For Each rng1 In rng '选中区域的每个单元格生成随机数
Do
rng1 = Int(Rnd * 100 + 1) '生成1~100的随机数
Loop Until Application.CountIf(rng, rng1) = 1 '循环判断随机数是否有重复
Next
End Sub
Sub 禁止或允许拖动单元格()
Application.CellDragAndDrop = False
End Sub
Sub 强制保存工作薄()
If Me.Saved = False Then Me.Save
End Sub
'使用Workbook对象
Sub AddWorkbook() '增加工作簿
Workbooks.add
End Sub
Sub AddNew() '增加工作簿
n = Workbooks.Count
Set NewBook = Workbooks.add
With NewBook
.Title = "新工作簿" & n
.SaveAs FileName:="新工作簿" & n & ".xlsx"
End With
End Sub
Sub OpenWorkbook() '打开工作簿
Workbooks.Open ("D:\Excel工作簿\使用Workbook对象.xls")
End Sub
Sub 打开工作簿()
Dim fm As String, flag As Boolean
flag = False
Do While Not flag '对话框打开已有Excel文件 打开文件对话框
fm = Application.GetOpenFilename(fileFilter:="Excel files(*.xls),*.xls, All files ( If fm <> "False" Then
Workbooks.Open fm
Set bb = ActiveWorkbook
flag = True
End If
Loop
End Sub
Workbooks.OpenText FileName:="员工花名册.txt", _
DataType:=xlDelimited, Tab:=True
End Sub
Sub 工作簿是否存在()
Dim str1 As String
str1 = Application.InputBox(prompt:="请输入Excel工作簿文件名：", _ Title:="文件名", Type:=2)
If str1 = "False" Then Exit Sub
str1 = ActiveWorkbook.Path & "\" & str1
If Not FileExists(str1) Then
MsgBox "工作簿“" & str1 & "”不存在!"
Else
Workbooks.Open str1
End If
End Sub
Function FileExists(FullFileName As String) As Boolean
'如果工作簿存在,则返回True
FileExists = Len(Dir(FullFileName)) > 0
End Function
Sub 工作簿是否打开()
Dim str1 As String
str1 = Application.InputBox(prompt:="请输入Excel工作簿文件名：", _ Title:="文件名", Type:=2)
'str1 = Application.GetOpenFilename
If str1 = "False" Then Exit Sub
If Not IsOpen(str1) Then
MsgBox "工作簿“" & str1 & "”未打开!"
Else
MsgBox "工作簿“" & str1 & "”已打开!"
End If
End Sub
Private Function IsOpen(WorkBookName As String) As Boolean
'如果该工作簿已打开则返回真
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks(WorkBookName)
If Err = 0 Then
IsOpen = True
Else
IsOpen = False
End If
End Function
Sub 保存新建工作簿()
Dim wb1 As Workbook
For Each wb1 In Workbooks
Next
End Sub
Sub 设置密码()
ActiveWorkbook.Password = InputBox("输入密码：")
Application.DisplayAlerts = False
ActiveWorkbook.Close
Application.DisplayAlerts = True
End Sub
Sub 取消密码()
ActiveWorkbook.Password = ""
End Sub
Sub 文档属性()
Dim r As Integer
Worksheets(1).Activate
Cells(1, 1) = "名称"
Cells(1, 2) = "类型"
Cells(1, 3) = "值"
Range("A1:C1").Font.Bold = True
With ActiveWorkbook
For r = 1 To .BuiltinDocumentProperties.Count
With .BuiltinDocumentProperties(r)
Cells(r + 1, 1) = .Name
Select Case .Type
Case msoPropertyTypeBoolean
Cells(r + 1, 2) = "Boolean"
Case msoPropertyTypeDate
Cells(r + 1, 2) = "Date"
Case msoPropertyTypeFloat
Cells(r + 1, 2) = "Float"
Case msoPropertyTypeNumber
Cells(r + 1, 2) = "Number"
Case msoPropertyTypeString
Cells(r + 1, 2) = "string"
End Select
On Error Resume Next
Cells(r + 1, 3) = .Value
On Error GoTo 0
End With
Next r
End With
Range("A:C").Columns.AutoFit
End Sub
Sub 获取文件名()
MsgBox "当前工作簿名称为：" & & vbNewLine & _ "当前工作簿全路径名为：" & ActiveWorkbook.FullName
End Sub
'使用worksheet对象
Dim i As Integer
With ActiveSheet
For i = 1 To Worksheets.Count - 1
.Cells(i + 2, 2).Value = Worksheets(i + 1).Name
.Hyperlinks.add anchor:=Cells(i + 2, 2), _
Address:="", SubAddress:=Cells(i + 2, 2).Value & "!a1", _
TextToDisplay:=Cells(i + 2, 2).Value
Next
End With
End Sub
Sub 删除超链接()
Dim h As Hyperlink, hs As Hyperlinks
Set hs = ActiveSheet.Hyperlinks
For Each h In hs
h.delete
Next
End Sub
Sub 新增工作表()
Dim str1 As String
On Error Resume Next
str1 = Application.InputBox(prompt:="请输入已有工作表名称，" & vbNewLine & _ "新增的工作表将位于该工作表前面。

", _
Title:="输入原工作表名称", Type:=2)
Worksheets.add Before:=Worksheets(str1)
End Sub
Sub delete_worksheet删除工作表()
Dim str1 As String
On Error GoTo err1
str1 = Application.InputBox(prompt:="请输入要删除的工作表名称：", _
Title:="输入工作表名称", Type:=2)
If str1 = "False" Then Exit Sub
Application.DisplayAlerts = False '不显示警告信息
Worksheets(str1).delete
Application.DisplayAlerts = True
Exit Sub
err1: '错误处理
MsgBox "不能删除工作表“" & str1 & "”！"
Application.DisplayAlerts = True
End Sub
Sub 工作表数量()
Dim i As Long
i = Worksheets.Count
End Sub
Sub 逐个激活工作表()
Dim sh As Worksheet
For Each sh In Worksheets
sh.Activate
MsgBox "激活工作表名称为：" & & vbNewLine & _
"单击【确定】按钮将激活下一工作表！"
Next
End Sub
Sub 选择前工作表()
If ActiveSheet.Index <> 1 Then
ActiveSheet.Previous.Activate
Else
MsgBox "已到第一个工作表"
End If
End Sub
Sub 选择后工作表()
If ActiveSheet.Index <> Worksheets.Count Then
ActiveSheet.Next.Activate
Else
MsgBox "已到最后一个工作表"
End If
End Sub
Sub 保护工作表()
On Error Resume Next
Dim ws1 As Worksheet
Dim str1 As String
str1 = Application.InputBox(prompt:="请输入保护工作表的密码：", _
Title:="输入密码", Type:=2)
For Each ws1 In Worksheets
ws1.Protect Password:=str1
Next
MsgBox "所有工作表保护完成！"
End Sub
Sub 撤消工作表保护()
On Error GoTo err1
Dim ws1 As Worksheet
Dim str1 As String
str1 = Application.InputBox(prompt:="请输入撤消保护工作表的密码：", _ Title:="输入密码", Type:=2)
For Each ws1 In Worksheets
ws1.Unprotect Password:=str1
Next
MsgBox "所有工作表的保护已被撤消！"
Exit Sub
err1:
MsgBox "输入的密码错误，不能取撤消对工作表的保护！"
Function WorksheetExists(ByVal sheetname As String) As Boolean
Dim sName As String
On Error GoTo err1
sName = Worksheets(sheetname).Name
WorksheetExists = True
Exit Function
err1:
WorksheetExists = False
End Function
Sub 复制工作表()
Dim ws1 As Worksheet
Set ws1 = ActiveSheet
MsgBox "复制当前工作到前面。

"
ws1.Copy Before:=ws1
MsgBox "得制当前工作表到后面。

"
ws1.Copy After:=ws1
End Sub
Sub 隐藏工作表()
Dim str1 As String, ws1 As Worksheet
str1 = Application.InputBox(prompt:="请输入需要隐藏的工作表：", _ Title:="隐藏工作表", Default:="Sheet1", Type:=2)
On Error GoTo err1
Set ws1 = Worksheets(str1)
ws1.Visible = xlSheetHidden
Exit Sub
err1:
MsgBox "输入的工作表不存在！"
End Sub
Sub 计算页数()
Dim r As Long, c As Long, p As Long
Dim ws1 As Worksheet
Set ws1 = ActiveSheet
c = ws1.HPageBreaks.Count + 1
r = ws1.VPageBreaks.Count + 1
p = r * c
MsgBox "当前工作表共有" & p & "页。

"
End Sub
Sub 工作表保护状态()
If ActiveSheet.ProtectContents Then
MsgBox "当前工作表已保护！"
Else
MsgBox "当前工作表未保护！"
End If
End Sub
Sub 删除图片()
Dim p As Shape
For Each p In ActiveSheet.Shapes
Next
End Sub
Sub 插入行()
Dim r As Long
r = Selection.Row
ActiveSheet.rows(r).Insert
End Sub
Sub 插入列()
Dim c As Long
c = Selection.Column
ActiveSheet.Columns(c).Insert
End Sub
Sub 设置行高()
Dim h As Long, r As Long, i As Integer, n As Integer
Dim ws1 As Worksheet
h = Application.InputBox(prompt:="请输入所选行的高度：", _ Title:="输入行高", Type:=1)
Set ws1 = ActiveSheet
n = Selection.rows.Count '选中区域的行数
r = ActiveCell.Row
For i = 1 To n
ws1.rows(r + i - 1).RowHeight = h
Next
Set ws1 = Nothing
End Sub
Sub 设置列宽()
Dim w As Long, c As Long, i As Integer, n As Integer
Dim ws1 As Worksheet
w = Application.InputBox(prompt:="请输入所选列的宽度：", _ Title:="输入列度", Type:=1)
If w = 0 Then Exit Sub
Set ws1 = ActiveSheet
n = Selection.Columns.Count
c = ActiveCell.Column
For i = 1 To n
ws1.Columns(c + i - 1).ColumnWidth = w
Next
Set ws1 = Nothing
End Sub
Sub 添加批注()
With Worksheets(1).Range("e5").AddComment
.Visible = False
.Text "批注日期: " & Date
End With
End Sub
Sub 查看批注()
Dim i As Integer, j As Integer
i = Worksheets(1).Comments.Count
For Each cm In Worksheets(1).Comments
j = j + 1
MsgBox "第" & j & "条/共" & i & "条批注" & vbCrLf & _
"作者:" & cm.Author & vbCrLf & "批注内容:" & cm.Text
Next
End Sub
Sub 删除批注()
Dim cm As Comment, str1 As String
Dim i As Integer, j As Integer
i = Worksheets(1).Comments.Count
For Each cm In Worksheets(1).Comments
j = j + 1
str1 = "第" & j & "条/共" & i & "条批注" & vbCrLf & _
"作者:" & cm.Author & vbCrLf & "批注内容:" & cm.Text & vbNewLine & vbNewLine str1 = str1 & "单击【是】按钮将删除该批注！"
If MsgBox(str1, vbQuestion + vbYesNo) = vbYes Then
cm.delete
End If
Next
End Sub
'使用Range对象
Sub 单元格序号()
Dim i As Long, j As Long
For i = 1 To 10
For j = 1 To 5
Cells(i, j).Value = (i - 1) * 5 + j
Next
Next
End Sub
Sub 选择连续数据区域()
Dim rng1 As Range
Dim i As Long, col As Long
i = Application.InputBox(prompt:="请输入要选择数据的行：", Type:=1)
col = Range("A" & i).End(xlToRight).Column
Set rng1 = Range(Cells(i, 1), Cells(i, col))
rng1.Select
Set rng1 = Nothing
End Sub
Sub 重叠区域()
Dim rng1 As Range, rng2 As Range, rng3 As Range
Set rng2 = Range("A1:E10")
Set rng3 = Range("C1:C10")
Set rng1 = Application.Intersect(rng2, rng3)
MsgBox rng1.Address
Sub 选择不连续数据区域()
Dim rng1 As Range, rng2 As Range
Set rng1 = Range("A1", Range("A1").End(xlDown))
Set rng2 = Range("E1", Range("E1").End(xlDown))
Union(rng1, rng2).Select
Set rng1 = Nothing
Set rng2 = Nothing
End Sub
Sub 引用子区域()
Dim rng1 As Range
Dim rng2 As Range
Set rng1 = Range("A1:C3, E1:F5, A8:C9")
rng1.Select
For i = 1 To rng1.Areas.Count
Set rng2 = rng1.Areas(i)
str1 = "子区域" & i & vbCr & vbCr
str1 = str1 & "行数：" & rng2.rows.Count & vbCr
str1 = str1 & "列数：" & rng2.Columns.Count
MsgBox str1
Next
Set rng1 = Nothing
Set rng2 = Nothing
End Sub
Sub 当前单元格地址()
Dim rng1 As Range
Dim str1 As String, strTitle As String
Set rng1 = ActiveCell
strTitle = "当前单元格地址"
str1 = "绝对地址：" & rng1.Address & vbCrLf
str1 = str1 & "行的绝对地址：" & rng1.Address(rowabsolute:=False) & vbCrLf
str1 = str1 & "列的绝对地址：" & rng1.Address(columnabsolute:=False) & vbCrLf
str1 = str1 & "以R1C1形式显示：" & rng1.Address(ReferenceStyle:=xlR1C1) & vbCrLf str1 = str1 & "相对地址：" & rng1.Address(False, False)
MsgBox prompt:=str1, Title:=strTitle
End Sub
Sub 当前区域信息()
Dim rng1 As Range, str1 As String
Set rng1 = ActiveCell.CurrentRegion
str1 = "当前区域信息：" & vbNewLine
str1 = str1 & "单元格数量：" & rng1.Cells.Count & vbNewLine
str1 = str1 & "行数：" & rng1.rows.Count & vbNewLine
str1 = str1 & "列数：" & rng1.Columns.Count & vbNewLine
str1 = str1 & "表头行数：" & rng1.ListHeaderRows
MsgBox str1, vbOKOnly, "当前区域信息"
End Sub
Sub 当前区域公式数量()
Dim c1 As Range, rng1 As Range
Dim i As Integer
Set rng1 = ActiveCell.CurrentRegion
For Each c1 In rng1.Cells
If c1.HasFormula Then
i = i + 1
End If
Next
If i > 0 Then
MsgBox "当前单元格所在区域共有 " & i & " 个公式。

"
Else
MsgBox "当前单元格所在区域没有公式。

"
End If
End Sub
Sub 追踪引用单元格()
ActiveCell.ShowPrecedents
End Sub
Sub 追踪从属单元格()
ActiveCell.ShowDependents
End Sub
Sub 批注显示状态()
Dim rng1 As Range, rng2 As Range
On Error Resume Next
Set rng1 = ActiveCell
Set rng2 = ActiveSheet.Cells.SpecialCells(xlCellTypeComments)
If rng2 Is Nothing Then Exit Sub
If Not Application.Intersect(rng1, rng2) Is Nothing Then
MsgBox "显示/隐藏当前单元格的批注。

"
ment.Visible = Not (ment.Visible)
End If
End Sub
Sub 不含公式的单元格()
Dim rng As Range, rng1 As Range, rng2 As Range
Set rng = edRange '当前使用单元格区域
rng.SpecialCells(xlCellTypeFormulas).Select '选择公式单元格
For Each rng1 In rng
If Application.Intersect(rng1, Selection) Is Nothing Then '单元格在公式区域 If rng2 Is Nothing Then
Set rng2 = rng1
Else
Set rng2 = Union(rng2, rng1) '合并区域
End If
End If
Next
rng2.Select '选择区域
Sub 删除某一列中有空值的行() '删除空行
Dim rng As Range
Set rng = ActiveSheet.Columns("h").SpecialCells(xlCellTypeBlanks) rng.EntireRow.delete
End Sub
Sub 复制公式()
Dim i As Integer
With Sheet1
.Range("E2").Copy
For i = 3 To 5
.Range("E" & i).PasteSpecial Paste:=xlPasteFormulas Next
End With
End Sub
Sub 设置错误值()
Dim arr1, i As Integer
arr1 = Array(xlErrNull, xlErrDiv0, xlErrValue, xlErrRef, _
xlErrName, xlErrNum, xlErrNA)
For i = 1 To 7
ActiveSheet.Cells(8, i).Value = CVErr(arr1(i - 1))
Next i
End Sub
Sub 判断错误类型()
Dim err_val
If IsError(ActiveCell.Value) Then
err_val = ActiveCell.Value
Select Case err_val
Case CVErr(xlErrDiv0)
MsgBox "#DIV/0! error"
Case CVErr(xlErrNA)
MsgBox "#N/A error"
Case CVErr(xlErrName)
MsgBox "#NAME? error"
Case CVErr(xlErrNull)
MsgBox "#NULL! error"
Case CVErr(xlErrNum)
MsgBox "#NUM! error"
Case CVErr(xlErrRef)
MsgBox "#REF! error"
Case CVErr(xlErrValue)
MsgBox "#VALUE! error"
Case Else
MsgBox "不可识别错误！"
End Select
End If
Sub 设置打印区域()
Dim str1 As String
str1 = edRange.Address
ActiveSheet.PageSetup.PrintArea = str1
str1 = ""
End Sub
Sub 拆分单元格()
Dim rng As Range
If Not Selection.MergeCells Then
MsgBox "选中区域不是合并区域！"
Exit Sub
End If
Selection.UnMerge '拆分单元格
For Each rng In Selection '逐个处理选中区域的单元格
If rng = "" Then '若当前单元格为空
rng = rng.Offset(-1, 0).Value '取上一单元格的值
End If
Next
End Sub
Sub 限制移动范围()
Dim rng1 As Range, str1 As String
Set rng1 = ActiveCell.CurrentRegion
str1 = rng1.Address
MsgBox "将单元格的移动范围限制在单元格当前区域 " & str1 & " 之内" ActiveSheet.ScrollArea = str1
End Sub
Sub 解除范围限制()
MsgBox "解除移动范围限制"
ActiveSheet.ScrollArea = ""
End Sub
Sub 删除单元格()
Dim rng1 As Range
Set rng1 = Selection
rng1.delete (xlShiftToLeft)
Set rng1 = Nothing
End Sub
Sub 按颜色统计单元格()
Dim rng As Range, rng1 As Range
Dim i As Integer, Arr(1 To 56) As Integer, k As Integer
Set rng = edRange '获取使用区域
For Each rng1 In rng '循环处理区域中的每个单元格
k = rng1.Interior.ColorIndex '获取填充色
If k <> xlColorIndexNone Then '具有底色
Arr(k) = Arr(k) + 1 '对应颜色数组中进行累加
End If
i = 8 '统计单元格显示的位置
For k = 1 To 56
If Arr(k) <> 0 Then
Cells(i, 1).Interior.ColorIndex = k
Cells(i, 2) = Arr(k)
i = i + 1
End If
Next
End Sub
Sub 自动套用格式()
Dim rng1 As Range
Set rng1 = Sheet1.Range("A1").CurrentRegion
rng1.AutoFormat
Set rng1 = Nothing
End Sub
Sub 设置边框线()
Dim rng1 As Range
Set rng1 = Sheet1.Range("A1").CurrentRegion
rng1.Borders.LineStyle = xlDouble
Set rng1 = Nothing
End Sub
Sub 增加缩排值()
On Error Resume Next
Selection.InsertIndent 1
End Sub
Sub 减少缩排值()
On Error Resume Next
Dim rng1 As Range
Set rng1 = Selection
If rng1.IndentLevel > 0 Then
rng1.InsertIndent -1
End If
Set rng1 = Nothing
End Sub
Sub 设置文本方向()
Dim i As Integer
i = Application.InputBox(prompt:="输入文字的角度（-90～90）：", Type:=1) If i >= -90 And i <= 90 Then
Selection.Orientation = i
End If
End Sub
Sub 自动换行()
Selection.WrapText = True
End Sub
Sub 缩小字体填充()
Selection.ShrinkToFit = True
End Sub
Sub 设置日期格式()
Dim rng As Range, rng1 As Range
Set rng1 = edRange
For Each rng In rng1
If IsDate(rng.Value) Then
rng.NumberFormatLocal = "yyyy""年""m""月""d""日"";@"
End If
Next
End Sub
Sub 大写金额()
Dim t As Currency, str1 As String
Dim i As Integer, strJ As String, strF As String
Dim rng1 As Range
With ActiveSheet
Set rng1 = Range("IV1").End(xlToRight) '获取最右侧列
t = ActiveCell.Value
With rng1
.Value = t
.NumberFormatLocal = "[DBNum2][$-804]G/通用格式"
.Columns.AutoFit
str1 = .Text
.Clear
End With
i = InStr(str1, ".")
If i > 0 Then
strJ = Mid(str1, i + 1, 1) '获取角部分字符
strF = Mid(str1, i + 2, 1) '获取分部分字符
If strF = "" Then
str1 = Left(str1, i - 1) & "元" & strJ & "角整"
Else
str1 = Left(str1, i - 1) & "元" & strJ & "角" & strF & "分" End If
Else
str1 = str1 & "元整"
End If
ActiveCell = "人民币" & str1
End With
End Sub
Sub 设置单元格图案()
Dim i As Integer
Dim r As Integer, g As Integer, b As Integer
Randomize
On Error Resume Next
For i = 1 To 18
With Selection.Interior
.Pattern = i
r = Int(Rnd * 255)
g = Int(Rnd * 255)
b = Int(Rnd * 255)。