VBA编程实例

2024年2月10日发(作者：)

VBA编程实例

第九章 工作表排序

本章只有一个范例文件，主要功能对活动工作簿中所有工作表进行排序。 算法说明:

1、统计活动工作簿中工作表的数量

WsCount=

2、定义一个一维数组a(1 to wscount)主要用来存放活动工作簿中所有工作表名称字符串 3、利用for each ws in eets 循环将活动工作簿中所有数量赋值给一维数组 4、利用冒泡法对数组进行排序(源文件对排序单独写了一个过程)

5、利用worksheets的move方法以及sheets(i)(他代表工作簿中从左到右第i张工作表)移动工作表 代码:

Sub SortSheet()

Dim WsCount As Integer

Dim WsArray() As String

Dim Ws As Worksheet

On Error Resume Next

WsCount = ReDim WsArray(1 To WsCount)

If tStructure Then

MsgBox & " 被保护，不能进行排序，请解除保护后排序", _

vbCritical, "不能排序工作表"

Exit Sub

End If

For Each Ws In eets

t = t + 1

WsArray(t) =

Next Ws

'对数组进行排序

For i = 1 To UBound(WsArray) - 1

For j = i + 1 To UBound(WsArray)

If WsArray(i) > WsArray(j) Then

t = WsArray(i)

WsArray(i) = WsArray(j)

WsArray(j) = t

End If

Next j

Next i

'利用Move方法以及Sheets(i)移动工作表，按指定的顺序排列

For i = 1 To WsCount

Worksheets(WsArray(i)).Move before:=Sheets(i) Next i

End Sub

第七章 批注

1、Comment为Range对象的属性

2、Comments返回指定工作表中所有的批注，可以利用For each对工作表中所有批注循环 题目:

(1)根据批注的作者，删除批注

(2)隐藏工作表中所有批注

(3)为区域中添加批注

(4)测试Comments(index)返回指定工作表中第index个批注

Sub 统计批注个数()

Dim Flag As Comment

'1、Comments返回指定工作表中所有的批注

'2、用Comment属性返回一个Comment对象

For Each Flag In ts

t = t + 1

Next Flag

MsgBox "活动工作表中共有:" & t & "个批注", vbOKOnly, "End Sub

Sub CountComment()

Dim Flag As Range

'利用err来判断是否发生错误

For Each Flag In nge

On Error Resume Next

t =

If Err = 0 Then k = k + 1 Next Flag

MsgBox "活动工作表中共有:" & k & "个批注", vbOKOnly, "End Sub

Sub 选定批注单元格()

Dim a() As Range

Dim Flag As Range

统计批注个数"

统计批注个数"

ReDim a() For i = 1 To

Set a(i - 1) = ts(i).Parent

Next i

Set Flag = a

End Sub

Sub selectcomment()

'使用编辑定位功能，定位批注，选定单元格

lCells(xlCellTypeComments).Select

End Sub

Sub 显示或隐藏批注()

Dim Flag As Comment

For Each Flag In ts

If e = True Then

e = False

Else

e = True

End If

Next Flag

End Sub

Sub DisHideComment()

'利用application的displaycommentindicator属性来显示隐藏批注

'Indicator表示批注的标识符

If yCommentIndicator = xlCommentAndIndicator Then

yCommentIndicator = xlCommentIndicatorOnly

Else

yCommentIndicator = xlCommentAndIndicator

End If

End Sub

Sub 输出所有批注()

'在Sheet2工作表中返回Sheet1工作表中所有批注

'这里使用返回批注中的内容

Dim Flag As Comment

Dim t As Integer

i = 1

With Worksheets("Sheet2")

.

.Cells(1, 1) = "第n个批注"

.Cells(1, 2) = "批注地址"

.Cells(1, 3) = "批注内容"

For Each Flag In Worksheets("Sheet1").Comments

i = i + 1

t = t + 1

.Cells(i, 1) = t

.Cells(i, 2) = s

.Cells(i, 3) =

Next Flag

.Columns("B:B").t

.Columns("C:C").ColumnWidth = 34

.t

End With

End Sub

Sub 改变批注颜色()

Dim Flag As Comment

For Each Flag In ts

Color = Int((80) * Rnd + 1) '1-80

ndex = Int((56) * Rnd + 1)

'1-56

Next Flag

End Sub

Sub 添加批注()

Dim Flag As Range

On Error Resume Next

For Each Flag In ("g8:i17")

t = t + 1

"hner:这是我添加的第" & t & "个批注" & Chr(13)

+ Chr(10) & Date

Next Flag

End Sub

Sub test()

MsgBox ("g8").

End Sub

Sub 删除批注()

Dim Flag As Range

For Each Flag In ("g8:i17")

Next Flag

End Sub

第十章 自定义函数

函数一:计算销售佣金

题1:根据销售额和对应的佣金率计算 =Sales*Rate 题2:根据销售额和对应的佣金率以及工作年限计算，工作每满一年佣金在原来的基础上增加一个百分点

=Sales*Rate*(1+Year/100)

条件 临界点 佣金率

[0，10000) 0 0.08

[10000，20000) 10000 0.105

[20000，40000) 20000 0.12

[40000，无穷) 40000 0.14

计算方法:

1、利用vlookup函数的模糊查找:=VLOOKUP(B2,$B$14:$C$17,2,TRUE)*B2 定期维护佣金率

2、利用if函数结合&连接符突破if七层嵌套问题:=IF(AND(B2>=0,B2<$B$15),B2*$C$14,"")

&IF(AND(B2>=$B$15,B2<$B$16),B2*$C$15,"")&IF(AND(B2>=$B$16,B2<$B$17),B2*$C$16,"")&IF(AND(B2>=

$B$17),B2*$C$17,"")

3、利用自定义函数，代码如下:

Function Commission1(Sales, years) '计算销售佣金，工作每满一年，销售佣金在原来的基础上增加一个百分点 Const Rate1 = 0.08

Const Rate2 = 0.105

Const Rate3 = 0.12

Const Rate4 = 0.14

Select Case Sales

Case 0 To 9999.99 'Case a to b 表示[a,b]两边都是闭区间

Commission1 = Sales * Rate1

Case 10000 To 19999.99

Commission1 = Sales * Rate2

Case 20000 To 39999.99

Commission1 = Sales * Rate3

Case Else

Commission1 = Sales * Rate4 End Select

'每工作满一年，佣金在原来的基础上增加1个百分点

Commission1 = Commission1 * (1 + years / 100)

End Function

Sub 计算销售佣金()

’在工作表中设计一个窗体按钮，执行此代码

Dim Sales

Dim years As Integer

Sales = Val(InputBox("请输入销售额:", "计算销售佣金"))

years = Val(InputBox("请输入工作年限:", "计算销售佣金"))

y = MsgBox("您的佣金为:" & Commission1(Sales, years), vbYesNo, "计算销售佣金") If y = vbYes Then '这里使用msgbox信息框，当单击是的时候，调用该过程本身计算销售佣金 End If

End Sub

函数二:随机抽取某区域中的一个单元格

目的:理解Optional定义变量和非易失性函数Volatile

1、易失性函数:顾名思义该函数很容易改变，也就是无论何时在工作表任意单元格输入数据，易失性函数都需要重新计算，结合本例，只要在任意单元格输入数据，易失性函数都重新计算 2、非易失性函数:顾名思义该函数不容易改变，也就是只有在函数中的参数值发生变化时，非易失性函数才重新计算，否则不计算，结合本例，只有在a1:a10输入数据，非易失性函数才重新计算，否则不计算 3、Optional申明变量，表示该变量为可选参数

4、假如Region为一个range对象区域，那么Region(i)表示区域Region中第i个对象

代码如下:

Function UnderstandVolatile(Region As Range, Optional FlagBoolean As

Boolean = False)

'利用optional定义变量表示该变量为可选参数

'理解非易失性函数

'函数功能:随机抽取Region区域中的一个单元格值

'当le true时，表示易失性函数

le FlagBoolean

'产生[a,b]之间的随机整数 Int(rnd()*(b-a+1)+1)

UnderstandVolatile = Region(Int(Rnd() * () + 1))

End Function

函数三:利用Optional来确定自定义函数是一个多单元格数组函数还是一个普通函数 MonthNames(Optional

Mindex)

函数功能:返回月份

可选参数:

1、当无参数时，返回一个多单元格数组公式，横向数组，将一个数组直接赋值给自定义函数 2、当参数大于等于1时，返回对应月份，如参数为1，则返回Jan，参数为13，也同样返回Jan 3、当参数小于等于0时，返回一个多单元格数组公式，垂直数组

代码如下:

Function MonthNames(Optional Mindex) '返回月份

'Ismissing(t)表示t是否传递给过程，如果没有传递，则返回true

Dim AllNames As Variant

AllNames = Array("Jan", "Feb", "Mar", _

"Apr", "May", "Jun", "Jul", "Aug", _

"Sep", "Oct", "Nov", "Dec")

If IsMissing(Mindex) Then

MonthNames = AllNames

Else

Select Case Mindex

Case Is >= 1

'如果参数为1，则返回Jan，为数组的第一个元素，故应该用(Mindex-1 mod

12)，数组的下限为0，即AllNames(0)

MonthNames = AllNames((Mindex - 1) Mod 12)

Case Else

MonthNames = ose(AllNames)

End Select

End If

End Function

这里使用一个ismissing函数，该函数主要是用来测试是否将参数传递给过程，如果没有传递，则返回TRUE。

如:在工作表中输入=MonthNames()此时并没有传递参数给过程

函数四:颠倒字符串

目的:运用vba函数和如何操作字符串

vba函数:

1、StrReverse(String)返回反向字符串，当string为空值时，则函数返回空字符窜，如果无参数，则返回null 2、MID(String,i,n)从字符串string的第i个位置开始提取长度为n的字符串

函数使用for i=len(string) to 1 step -1

n=mid(string,i,1)

'遍历字符串中的每个字符，此方法可以运用到数字与字符分离或者字符串中各数字求和等

next i

Function MstrReverse(Mstring) As String '利用vba函数StrReverse返回反向字符串

MstrReverse = erse(Mstring) End Function

Function Mstrreverse1(Mstring) As String Dim i As Integer

For i = Len(Mstring) To 1 Step -1

Mstrreverse1 = Mstrreverse1 & Mid(Mstring, i, 1) Next i

End Function

Sub Mstrreverse2()

Mstring = InputBox("请输入字符串:", "反向字符串")

If Mstring = "" Then Exit Sub

MsgBox "字符串:" & Mstring & "的反向字符串为:" & vbCrLf &

MstrReverse(Mstring), vbOKOnly, "反向字符串"

End Sub

小窍门:在实际输入vba代码时，可能没有熟记vba常量或者vba函数，此时可以在vbe中按ctrl+j返回常数列表，供选择。或者输入vba.则返回vba函数供选择。

函数五:字符串全部大写或者全部小写 AlUcLcase(Mstring, Optional

Mboolean As Boolean = True)

算法:

、遍历字符串中的每个字符 1

2、对字符串中的每个字符进行判断

条件一:如果函数的第二个参数省略或者第二个参数为TRUE时，表示要将字符串全部大写 、如果ASC(字符)在[97，122]，那么，表示该字母为小写字母需要转换。转换字符=CHR(ASC(字符)-32) 1

2、如果不满足上述条件，表示字母表示大写字母或者非字母，此时不需要转换，只需字符连接 条件二:如果函数的第二个参数为False时，表示要将字符串全部小写

1、如果ASC(字符)在[65，90]，那么，表示该字母为大写字母需要转换。转换字符=CHR(ASC(字符)+32) 2、如果不满足上述条件，表示字母表示小写字母或者非字母，此时不需要转换，只需字符连接

vba函数

1、ASC(字符)表示返回字符的ASICC码，相当于EXCEL工作表中的CODE函数

2、CHR(数字)表示返回数字对应的字符，相当于EXCEL工作表中的CHAR函数

3、UCASE(字符)表示将字符全部大写，相当于EXCEL工作表中的UPPER函数

、LCASE(字符)表示将字符全部小写，相当于EXCEL工作表中的LOWER函数 4

代码如下:

Function AlUcLcase(Mstring, Optional Mboolean As Boolean = True) As

String

'字符串大小写转换，如果省略第二个参数，则将字符串全部大写显示，否则小写显示 Dim i As Integer

Dim Mlen As Integer

Dim SngString As String

Dim Mcode As Integer

Dim AimString As String

Mlen = Len(Mstring)

For i = 1 To Mlen

SngString = $(Mstring, i, 1)

Mcode = (SngString)

'注意下面的条件，Ismissing表示当参数省略时，或者当参数为True时，表示将字符串全部大写

If IsMissing(Mboolean) Or Mboolean = True Then

If Mcode >= 97 And Mcode <= 122 Then

AimString = AimString & (Mcode - 32)

Else

AimString = AimString & SngString

End If

Else

If Mcode >= 65 And Mcode <= 90 Then

AimString = AimString & (Mcode + 32)

Else

AimString = AimString & SngString

End If

End If

Next i

AlUcLcase = AimString

End Function

Function AlUcLcase1(Mstring, Optional Mboolean As Boolean = True) As

String

'字符串大小写转换，如果省略第二个参数，则将字符串全部大写显示，否则小写显示 If IsMissing(Mboolean) Or Mboolean = True Then

AlUcLcase1 = $(Mstring) Else

AlUcLcase1 = $(Mstring)

End If

End Function

Excel2003高级VBA编程---第11章 VBA编程示例和技巧

实例一:利用EXCEL的FileSearch属性批处理查找文件

下面实例主要论证以下几个问题:

1、Application的FileSearch属性，该属性返回一个FoundFiles对象，也就是根据指定的条件，查找出来的满

足条件的文件集合，可以利用For each对该集合进行循环。如:要查找D盘根目录下，所有TXT文件

'下面的代码返回一个FoundFiles属性

With arch

.LookIn = "c:"

.FileName = "*.txt"

.Execute

'对上述属性进行操作

i=1

for each fs in .FoundFiles

with activesheet

.cells(1,1)="序号"

.cells(1,2)="路径"

i=i+1

.cells(I,1)=I

.cells(I,2)=fs

end with

next fs

2、利用工作簿的opentext方法，将文本文件导入到工作表中

3、过程调用，如果某些过程比较通用，最好使用该方法，以提高代码编写效率

具体实例:

Sub FileProcess()

'文件批处理，将某文件夹下所有文本文件导入到excel工作簿中 Dim

FileFind As FileSearch

Dim fs As Variant

Dim FilePath As String

Dim FileStyle As String

FilePath = & "" FileStyle = "*.txt"

With arch

.LookIn = FilePath

.Filename = FileStyle

.Execute

If . = 0 Then

MsgBox "没有找到指定类型的文件"

Exit Sub

End If

For Each fs In .FoundFiles

Call EveryText1(fs)

Next fs

End With

End Sub

Sub EveryText(fs)

xt Filename:=fs, startrow:=1

Range("d1") = "代码"

Range("e1") = "个数"

Range("f1") = "金额"

Range("d2") = "A"

Range("D3") = "B"

Range("D4") = "C"

Range("E2:e4") = "=countif(b:b,d2)" Range("f2:f4") =

"=sumif(b:b,d2,c:c)"

End Sub

Sub EveryText1(fs)

Dim i As Integer

i = 1

With ActiveSheet

.

.Cells(1, 1) = "序号"

.Cells(1, 2) = "文件路径"

i = i + 1

.Cells(i, 1) = i - 1

.Cells(i, 2) = fs

.t End With

End Sub

实例二:填充单元格，测试教训

1、尽量减少对象的访问，尤其在循环中。适当情况可以考虑数组替代对象，最后再将数组赋值给对象

2、在内存中一维数组只能是列数组，如果需要给行赋值，则需要利用工作表函数transpose进行转置

3、尽量明确变量的类型以及常量的定义，以方便日后，修改代码 3、有点疑问在时间测试时，每次时间都不一致，更加不解的是代码运行时间有时还为负，不可能啊～

代码如下:

Sub 填充单元格()

Dim StartTime As Long

StartTime = Timer

MsgBox "测试直接填充单元格时间"

Const cols = 200

With Sheet

.

For i = 1 To cols

.Cells(1, i) = i

Next i

.t End With

StartTime, "0.000") & "秒" MsgBox "利用单元格赋值填充单元格共需要的时间为:" & Format(Timer -

End Sub

Sub 数组填充()

Dim StartTime As Long

Dim a()

StartTime = Timer

MsgBox "利用数组填充单元格时间测试"

Const cols = 200

ReDim a(1 To cols)

'数组赋值

For i = 1 To cols

a(i) = i

Next i

With Sheet

.

.Range(Cells(1, 1), Cells(1, cols)) = a

.t End With

MsgBox "利用数组赋值填充单元格共需要的时间为:" & Format(Timer -

StartTime, "0.000") & "秒"

End Sub

Sub 填充单元格行()

Dim Marray()

Dim i As Long 'i>32767 如果此处定义为整型，则溢出

Dim StartTime As Long

Updating = False StartTime = Timer

Const Row = 40000

ReDim Marray(1 To Row)

For i = 1 To Row

Marray(i) = i

Next i

Range(Cells(1, 1), Cells(Row, 1)) =

ose(Marray)

'下面的数组为列数组，所以需要利用工作表函数transpose转置

'Range(Cells(1, 1), Cells(Row, 1)) = Marray

Updating = True MsgBox "共填充了:" & Row & "行" &

vbCr & "利用数组赋值得时间为:" & Format(Timer - StartTime, "0.00") &

"秒"

End Sub

Sub 填充单元格行1()

Dim i As Long 'i>32767 如果此处定义为整型，则溢出

Dim StartTime As Long

Updating = False StartTime = Timer

Const Row = 40000

For i = 1 To Row

Cells(i, 1) = i

Next i

Updating = True MsgBox "共填充了:" & Row & "行" &

vbCr & "在循环中引用对象，直接赋值得时间为:" & Format(Timer -

StartTime, "0.00") & "秒"

End Sub

Sub 利用数组填充单元格行65536()

Dim Marray()

Dim i As Long 'i>32767 如果此处定义为整型，则溢出

Dim StartTime As Long

Updating = False StartTime = Timer

Const Row = 65536

ReDim Marray(1 To Row)

For i = 1 To Row

Marray(i) = i

Next i

Range(Cells(1, 1), Cells(Row, 1)) =

ose(Marray)

'下面的数组为列数组，所以需要利用工作表函数transpose转置

'Range(Cells(1, 1), Cells(Row, 1)) = Marray

Updating = True MsgBox "共填充了:" & Row & "行" &

vbCr & "利用数组赋值得时间为:" & Format(Timer - StartTime, "0.00") &

"秒"

End Sub

Sub 直接填充单元格行65536()

Dim i As Long 'i>32767 如果此处定义为整型，则溢出

Dim StartTime As Long

Updating = False StartTime = Timer

Const Row = 65536

For i = 1 To Row

Cells(i, 1) = i

Next i

Updating = True MsgBox "共填充了:" & Row & "行" &

vbCr & "在循环中引用对象，直接赋值得时间为:" & Format(Timer -

StartTime, "0.00") & "秒"

End Sub

Sub 利用数组填充整个工作表()

Dim i As Long

'注意变量的声明，如果知道变量的范围最好将其明确变量类型，以提高代码速度 Dim j As Integer

Dim StartTime As Long

Dim Marray()

Updating = False

StartTime = Timer

Const irow = 1000

Const jcolumn = 256

ReDim Marray(1 To irow, 1 To jcolumn)

For i = 1 To irow

For j = 1 To jcolumn

Marray(i, j) = i * j

Next j

Next i

Range(Cells(1, 1), Cells(irow, jcolumn)) = Marray

Updating = True MsgBox "共填充了:" & irow & "行" &

jcolumn & "列" & vbCr& "在循环中引用对象，直接赋值得时间为:" &

Format(Timer - StartTime, "0.00")& "秒"

End Sub

Excel2003高级VBA编程---第11章 VBA编程示例和技巧

实例五 vba中运用excel工作表函数

'以下代码主要测试parent属性，即对象的父对象(上一级)

Function WsName(Optional Rng As Range) As String

'optional在函数中表示optional命名的参数为可选参数

'利用rng是否存在，来判断函数是否有参数

If Rng Is Nothing Then

WsName = Else

WsName = End If

End Function

Function WbName(Optional Rng As Range) As String

If Rng Is Nothing Then

WbName = Else

WbName =

End If

End Function

Function AppName(Optional Rng As Range) As String

If Rng Is Nothing Then

AppName = Else

AppName =

End If

End Function

Function SumCountIF(DataRng As Range, Llimit, Ulimit, SCBoolean As

Boolean)

'条件求和计数，这里的上下限都是闭区间，当SCBoolean为true时，求和

Dim Rng As Range

Dim t

'下面代码数据多时，速度会减慢，建议直接使用工作表函数

'For Each Rng In DataRng

' If Rng >= Llimit And Rng <= Ulimit Then

' Select Case SCBoolean ' Case True

' t = t + Rng

' Case Else

' t = t + 1

' End Select

' End If

'Next Rng

If Llimit >= Ulimit Then

k = Llimit

Llimit = Ulimit

Ulimit = k

End If

With eetFunction If SCBoolean = True Then

t = .SumIf(DataRng, ">=" & Llimit) - .SumIf(DataRng, ">" & Ulimit)

Else

t = .CountIf(DataRng, ">=" & Llimit) - .CountIf(DataRng, ">" &

Ulimit)

End If

End With

SumCountIF = t

End Function

Function SumCountVisible(DataRng As Range, SCBoolean As Boolean)

'可见单元格求和计数，将该函数设置为易失性函数

Dim Rng As Range

le True

For Each Rng In DataRng

If = False And = False

Then

If SCBoolean = True Then

t = t + Rng

Else

t = t + 1

End If

End If

Next Rng

SumCountVisible = t

End Function

实例六 基础设置

小结:本节主要论证如何在vba中进行Excel的基础设置,例如:

1、文本自动换行切换

xt = Not xt 、自动切换行号和列标 2

yHeadings = Not yHeadings

3、自动切换网络线

yGridlines = Not yGridlines

4、切换工作表标签

.DisplayWorkbookTabs = Not .DisplayWorkbookTabs 5、切换编辑栏

.DisplayFormulaBar = Not .DisplayFormulaBar 6、切换状态栏

.DisplayStatusBar = Not .DisplayStatusBar 、切换任务栏窗口 7

.ShowWindowsInTaskbar = Not .ShowWindowsInTaskbar

在实际应用中，如果没有记住这些属性，可以录制一个宏进行相关方法、对象的学习。 具体代码如下:

Sub 自动换行切换()

'切换换行格式，wraptext单元格格式设置文本为自动换行

'只要格式设置为true或者false都可以利用not进行自动切换

If TypeName(Selection) = "Range" Then

xt = Not xt End If

End Sub

Sub 自动切换行号和列标()

'利用activewindows的displayheadings属性切换行号和列标

yHeadings = Not yHeadings

End Sub

Sub 自动切换网络线()

yGridlines = Not yGridlines

End Sub

Sub 自动切换编辑栏等()

With ActiveWindow

.DisplayWorkbookTabs = Not .DisplayWorkbookTabs '切换工作表标签

End With

With Application

.DisplayFormulaBar = Not .DisplayFormulaBar '切换编辑栏

.DisplayStatusBar = Not .DisplayStatusBar '切换状态栏

.ShowWindowsInTaskbar = Not .ShowWindowsInTaskbar '切换任务栏窗口

End With

End Sub

实例七 实用函数

小结:

本节通过实例介绍了一些比较实用的函数，包括查找某个文件是否存在、从包含路径的文件中提取文件名、判断单元格名称是否存在、判断某个工作表是否存在和某工作簿是否打开,

、Dir[(pathname[, attributes])]函数，返回一个 String，用以表示一个文件名、目录名或文件夹名称，它必须与1

指定的模式或文件属性、或磁盘卷标相匹配。如果文件不存在，则返回空值，运用此函数可以查找某路径下文件是否存在,

2、利用mid函数和parator(返回路径分隔符)从路径中提取文件名

3、单元格名称在vba中的运用

4、利用工作表或者工作簿属性结合err=0来判断工作表是否存在、工作簿是否打开, Function SheetExists(Nname As String) As Boolean '在活动工作簿中查找某个工作表是否存在

'这里主要定义一个对象变量，然后对对象变量赋值，如果没有发生错误，也就是ERR=0，那么SheetExists=true

Dim t As Object

On Error Resume Next

Set t = eets(Nname) SheetExists = False

If Err = 0 Then SheetExists = True

End Function

具体代码如下:

Function FileExists(FileName As String) As Boolean Dim FlagString As

String

'利用dir函数判断某个文件是否存在，dir函数返回一个字符串，如果某个文件不存在，则返回空字符串 FlagString = Dir(FileName)

If FlagString = "" Then

FileExists = False

Else

FileExists = True

End If

End Function

Function FileNameOnly(FileName As String) As String '从包含路径的文件名中提取文件，pathseparator返回路径分隔符""

Dim I As Integer

Dim ChrLen As Integer

Dim FlagString As String

Dim t As String

ChrLen = (FileName)

For I = ChrLen To 1 Step -1

FlagString = (FileName, I, 1)

If FlagString = parator Then Exit For

'If FlagString = "" Then Exit For

t = FlagString & t

Next I

FileNameOnly = t

End Function

Function RangNameExist(Nname As String) As Boolean

'判断某个区域名称是否存在，Names集合/Name属性

Dim N As Name

RangNameExist = False

For Each N In

If UCase() = UCase(Nname) Then

RangNameExist = True

Exit Function

End If

Next N

End Function

Function SheetExists(Nname As String) As Boolean '在活动工作簿中查找某个工作表是否存在

'这里主要定义一个对象变量，然后对对象变量赋值，如果没有发生错误，也就是ERR=0，那么SheetExists=true

Dim t As Object

On Error Resume Next

Set t = eets(Nname) SheetExists = False

If Err = 0 Then SheetExists = True End Function

Function WorkbookIsOpen(WbName As String) As Boolean

Dim t As Object

'判断某工作簿是否打开

On Error Resume Next

Set t = Workbooks(WbName)

WorkbookIsOpen = False

If Err = 0 Then WorkbookIsOpen = True End Function

Sub 查找工作表是否存在()

Dim t As String

'函数调用，如果SheetExists定义为Private函数，则此处不能调用，因为他们不在一个模块中 t = InputBox("请输入需要查找的工作表名:", "查找工作表", )

If t = "" Then Exit Sub

If SheetExists(t) = True Then

MsgBox t & "工作表找到"

eets(t).Select Else

MsgBox t & "工作表没有找到"

End If

End Sub

实例八 快速插入若干行

在实际工作中，有时需要插入很多行，通常是选定插入的行数，然后点击插入行。也可以使用快捷键alt+i+r。但当插入行如果超过100行，利用上述方法很不方便，此时可以利用下面代码完成。

Sub InsertMultipleRows()

'根据用户要求插入若干行

Dim InsertRows As Long

Dim BeginRow As Long

'如果没有选中的单元格或者单元格区域，则退出

If LCase(TypeName(Selection)) <> "range" Then

MsgBox "请选择需要插入的起始行或者第一行的单元格", vbInformation, "复杂插入行"

Exit Sub

End If

'返回选定单元格或者单元格区域的顶部行所在的行数，这里使用(1).row更好理解 BeginRow =

'要求用户输入需要插入的行数

入要插入的行数:", "复杂插入行", 1)) InsertRows = Val(InputBox("请输

'如果输入数据小于零，则退出

If InsertRows <= 0 Then

MsgBox "对不起，输入有误，不能插入行～"

Exit Sub

End If

'插入行

Rows(BeginRow & ":" & InsertRows + BeginRow - 1).Insert

shift:=xlDown

End Sub

实例九:工作表小技巧

、工作表汇总:在实际工作中，如果各工作表结构一样，需要将工作簿中各工作表汇总在一张工作表中，此1

时，运用下面代码:

Sub TotalWs()

'汇总工作表，任何时刻都可以执行本代码重新进行工作表汇总

Dim Ws As Worksheet

Dim IWs As Integer

Dim MaxRow As Long

On Error Resume Next

'检查汇总工作表是否存在，如果不存在，插入一个汇总工作表，并放在第一个位置 Set Ws = eets("汇总")

If Ws Is Nothing Then

Sheets(1).Activate

= "汇总"

Else

'如果汇总工作表存在，现将汇总工作表放在第一个位置，然后清除改工作表所有内容，重新汇总

Worksheets("汇总").Move before:=Sheets(1)

Worksheets("汇总").ontents

End If

'将工作表标题复制到汇总工作表中

Sheets(2).Select

Range("a1"). Destination:=Sheets(1).Range("a1")

MaxRow = 2

For IWs = 2 To

'这里必须要激活工作表，而不是选定

Worksheets(IWs).Activate

Range("a1").

(1, 0).Resize( - 1).Copy

Destination:=Worksheets(1).Cells(MaxRow, 1)

MaxRow = Worksheets(1).Range("a65536").End(xlUp).Row + 1

Next IWs

MsgBox "工作表汇总完毕，请检验～", vbInformation, "工作表汇总"

Worksheets(1).Activate

End Sub

2、隐藏取消隐藏工作表

方法一:alt+o+h+h隐藏工作表 或者点击格式-工作表-隐藏工作表

方法二:在vbe中设置工作表属性visible，如果选择-1则表示显示工作表，如果选择0则隐藏工作表，且该工作表不能在工作表窗口中取消隐藏。如果选择1则隐藏工作表，且只能在vbe中通过修改visible属性来取消隐藏工作表

3、切换工作表

ctrl+pageup/ctrl+pagedown

4、通过工作表中某单元格值来排序工作表

Sub WsSortCell()

'通过工作表中单元格值进行排序

Const irow = 1

Const jcolumn = 1

Dim i As Integer

Dim j As Integer

Dim WsCount As Integer

WsCount = '冒泡法排序

If WsCount = 1 Then Exit Sub

For i = 1 To WsCount - 1

For j = i + 1 To WsCount

If Sheets(i).Cells(irow, jcolumn) > Sheets(j).Cells(irow, jcolumn)

Then

Sheets(j).Move before:=Sheets(i)

End If

Next j

Next i

End Sub

5、快速插入新的工作表

插入工作表:shift+f11

删除工作表:alt+e+n

6、利用cell函数返回工作表所在路径及名称

(1)=cell("filename") 含路径和文件名

(2)仅返回工作表名

=RIGHT(CELL("filename"),LEN(CELL("filename"))-FIND("]",CELL("filename")))

(3)返回工作簿名称

=MID(CELL("filename"),FIND("[",CELL("filename"))+1,FIND("]",CELL("filename"))-FIND("[",CELL("filename")

)-1)

7、调整新增工作簿后工作表数量

工具-选项-常规-工作簿中工作表数量

8、快速合并单元格，通过录制宏，为宏设置快捷键，以后直接通过快捷键来合并单元格。本实例主要是验证为宏添加快捷键，以方便快速执行宏

为宏设置快捷键步骤如下:

工具-宏-选项-设置快捷键(当然要选择已经设计好的宏)

实例十 工作表标签

1、动态命名工作表，可以在工作表中输入工作表名，然后利用vba来读取单元格命名工作表

Sub DynamicWsName()

Dim FlagString As String

Dim Ws As Worksheet

Dim t As Integer

On Error Resume Next

Set Ws = Worksheets("定义工作表名")

t = WsCount

If Ws Is Nothing Then

before:=Worksheets(1)

= "定义工作表名"

Range("a1:b1") = Array("序号", "工作表名")

Range("a2").Formula = "=if(row(a1)<=" & t & ",row(a1),0)"

Range("a2").AutoFill Destination:=Range("A2:A14"),

Type:=xlFillDefault

MsgBox "请输入工作表名"

Range("b2").Select

Exit Sub

End If

te

i = 2

Do While (i, 1) <> 0

Worksheets(i).Activate

If Len((i, 2)) <> 0 Then

= (i, 2)

End If

i = i + 1

Loop

Worksheets(1).Activate

End Sub

Function WsCount()

'统计工作表的数量

le

WsCount = End Function

2、调整工作表标签字体大小，在Excel中不能直接调整工作表标签字体的大小，此时可以在windows桌面上右键-属性-外观-高级-项目-共具提示-字体来设置

3、新增工作表，表名为yyyy-mm-dd 第n周，其中:日期为每一周的第一天，也就是星期日，第一天和最后一天除外。第一天为某年的第一天，最后一天为12月31日

Sub YearWeek()

'下面的代码增加52个工作表，且每个工作表名为第n周的第一天(星期天)日期

Dim i As Integer

Dim Ws As Worksheet

Dim InYear As Integer

Dim Marr(1 To 7, 1 To 2)

Dim Arr As Variant

Dim Msg As String

Dim Day01 As Date

'如果工作表存在，则不添加

On Error Resume Next

'数字转换

Arr = Array("一", "二", "三", "四", "五", "六", "日")

Updating = False

Worksheets(1).Cells(1).ClearContents For i = 1 To 7

Marr(i, 1) = i

Marr(i, 2) = Arr(i - 1)

Next i

InYear = Val(InputBox("请输入年", "增加本年周工作表", Year(Date)))

After:=Worksheets(), Count:=(52 -

)

i = 0

date01 = DateSerial(InYear, 1, 1) For Each Ws In

eets

i = i + 1

If i = 1 Then

= Format(date01, "yyyy-mm-dd") & " 第" & i & "周"

Else

If i = 2 Then

= Format(date01 + 7 - Weekday(date01) + 1, "yyyy-mm-dd") & "

第" & i & "周"

t = date01 + 7 - Weekday(date01) + 1

Else

t = t + 7

= Format(t, "yyyy-mm-dd") & " 第" & i & "周"

End If

End If

Next Ws

Worksheets(1).Cells(1, 1) = InYear & "年1月1日为:星期"

&p(Weekday(DateSerial(InYear, 1,

1))+ 1, Marr, 2, False)

Updating = True End Sub

4、快速复制工作表

Alt+E+M调用移动复制工作表对话框，如果想复制工作表则选择副本，否则不选择;如果在同一工作簿中

快速复制工作表，则可以利用ctrl和鼠标复制工作表

5、快速选择工作表

(1)直接点击工作表标签

(2)在最左边工作表标签拐角处右键，然后选择工作表

(3)通过下面的代码将各工作表名称放置在目录工作表中，并建立超级链接，直接在目录中选择工作表

Sub List()

'产生目录

Dim Ws As Worksheet

Dim WsActive As Worksheet

Dim Ml As Worksheet

'当工作表不存在时，会产生一个错误，此时忽略错误，继续执行下面的语句，即ml为nothing

On Error Resume Next

Updating = False yAlerts = False

Set Ml = Worksheets("目录")

If Not (Ml Is Nothing) Then

End If

before:=Worksheets(1) Set WsActive = ActiveSheet

= "目录"

Range("a1") = "目录"

Range("a1"). = True Range("a1:d1").Merge

Range("a2") = "序号"

Range("b2") = "工作表名称"

i = 2

For Each Ws In Worksheets

If <> Then

i = i + 1

Cells(i, 1) = i - 2

Cells(i, 2) =

'建立超级链接，注意超级链接的书写方式 '2005-12-5 星期一'!A1

Anchor:=Worksheets("目录").Cells(i, 2),

Address:="", SubAddress:= _

"'" & & "'!a1", TextToDisplay:=

End If

Next Ws

With

.Size = 9

.Underline = xlUnderlineStyleNone

End With

Range("a1"). = 14

s("a:iv").AutoFit

yAlerts = True Updating = True

End Sub

6、返回工作表名

方法一:利用excel宏函数cell("filename")

=RIGHT(CELL("filename"),LEN(CELL("filename"))-FIND("]",CELL("filename")))

方法二:在vba中定义函数

Function WsName()

WsName =

End Function

7、根据年月增加工作表(工作表数量为某年某月的天数) Private Sub

CommandButton1_Click() '根据输入的年份和月份新增工作表，工作表名称'yyyy-mm-dd 星期几" '直接在工作表窗口中按ctrl+w执行本代码

Dim MDay As Integer

Dim MYear As Integer

Dim MMonth As Integer

Dim Ws As Worksheet

Dim WsCount As Integer

Dim MDate As Date

Dim i As Integer

Dim Marr As Variant

Dim Arr()

Dim t As String

yAlerts = False Updating = False

'删除源工作表

For Each Ws In Worksheets

If <> Then

Next Ws

= "根据月份插入新工作表"

MYear = Val(r) MMonth = Val(th)

If MYear = 0 Or MMonth = 0 Or MMonth < 1 Or MMonth > 12 Then

MsgBox "年和月份不能为空～", vbInformation, "年月份校验"

us

'注意退出sub，但窗体仍在内存中

Exit Sub

End If

'MYear年MMonth月的最后一天日期

MDate = DateSerial(MYear, MMonth + 1, 0)

'MYear年MMonth月共多少天

MDay = Day(MDate)'增加MDay个工作表

WsCount =

after:=Worksheets(WsCount), Count:=(MDay - WsCount)

'创建一个二维数组，以方便后面对星期数字的查找{1,"日";2,"一";3,"二";4,"三";5,"四";6,"五";6,"六"} Marr = Array("日", "一", "二", "三", "四",

"五", "六")

ReDim Arr(1 To 7, 1 To 2)

For i = 1 To UBound(Arr, 1)

Arr(i, 1) = i

Arr(i, 2) = Marr(i - 1)

Next i

'遍历工作簿中所有工作表

i = 0 '注意前面的i=8，此时要清零，重新利用该变量

For Each Ws In eets

'存储天数

i = i + 1

MDate = Format(DateSerial(MYear, MMonth, i), "yyyy-mm-dd")

t = p(Weekday(MDate), Arr, 2,

False)

= MDate & " 星期" & t

Next Ws

Worksheets(1).Activate

Updating = True yAlerts = True

MsgBox "执行完毕～"

Unload Me

End Sub

8、隐藏工作表

方法一:按ALT+O+H+H隐藏，相当于格式-工作表-隐藏，此方法缺点，用户可以取消隐藏，除非为工作表加密

方法二:通过VBE中设置工作表的VISIBLE属性来隐藏工作表，其中，要两种隐藏方式 (1) visible=xlsheethidden此隐藏方式类同于方法一

(2) visible=xlsheetveryhidden绝对隐藏，此方法不能直接在工作表窗口中取消隐藏，只能通过在vbe中修改visible属性为xlsheetvisible

实例十一 保护工作表

在Excel中，函数的应用频率相当高。有时候，介于个人知识的保密或者其他原因，不想让他人看到公式，而无公式的单元格可以随意修改。此时，可以利用下面的方法来保护公式

1、按ctrl+a全选工作表中所有单元格，右键单击设置单元格格式，选择保护选项卡，将锁定隐藏去掉对勾，然后使用ctrl+g编辑定位公式单元格，设置公式单元格保护属性锁定隐藏打勾，最后保护工作表。经过上述处理，有公式的单元格不能修改，也不能查看公式，而非公式单元格可以编辑。

2、如果工作表很多，利用上述方法速度慢，此时，可以利用vba解决

Sub protectsheet()

Dim Ws As Worksheet

Updating = False

On Error Resume Next

For Each Ws In Worksheets

If <> "报表目录" Then

Set range0 = ion

= False

aHidden = False

lCells(xlCellTypeFormulas, 23).Select

= True

aHidden = True

Set range0 = Nothing

Range("a1").Activate

t Password:="888", DrawingObjects:=False,

Contents:=True, Scenarios:= _ False,

AllowFormattingCells:=True, AllowFormattingColumns:=True, _

AllowFormattingRows:=True,

AllowSorting:=True, AllowFiltering:=True, _

AllowUsingPivotTables:=True

End If

Next Ws

Worksheets("报表目录").Select

Range("f5").Select

Updating = True

End Sub

17#实例十二 如何判断工作簿中是否包含外部链接

外部链接公式又一个特点，如:=[Book1]Sheet1!$D$9，所以我们只需要查找公式中是否包含"["这个符号，如果包含则表明有外部链接，否则没有。

解决方法:将外部链接单元格表名以及单元格地址在立即窗口中反映

解决步骤:

1、遍历工作簿中每个工作表

2、在每个工作表中定位有公式的单元格赋值给range对象

3、遍历工作表中有公式的单元格

4、判断公式中是否包含"["这个符号

5、在立即窗口中返回结果

具体代码如下:

Sub OutSideLink()

'查找有外部链接的单元格

Dim Ws As Worksheet

Dim FormulaRng As Range

Dim FlagRng As Range

Dim k As Integer

'运用on error语句主要是为了避免发生错误，如果某个工作表中没有公式单元格则会发生错误，此时应该接着

执行下面一个工作表

On Error Resume Next

'遍历工作簿中所有的工作表

For Each Ws In eets

te

'将有公式的单元格赋值给formularng

Set FormulaRng = lCells(xlCellTypeFormulas, 23)

'如果存在则在公式单元各中循环

If Not FormulaRng Is Nothing Then

For Each FlagRng In FormulaRng

'外部链接公式又一个特点，则肯定会引用工作簿，表现形式:=[Book1]Sheet1!$D$9，所以只要查找

"["这个符号

k = InStr(1, a, "[")

If k <> 0 Then

& " " & s

End If

Next FlagRng

End If

Next Ws

End Sub