VBA编程实例

第九章工作表排序

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

法说明:

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

WsCount=Activeworkbook.worksheets.count

2、定义一个一维数组a(1 to wscount)主要用来存放活动工作簿中所有工作表

名称字符串 3、利用for each ws in activeworkbook.worksheets 循环将活动工

作簿中所有数量赋值给一维数组 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 = ActiveWorkbook.Worksheets.Count ReDim WsArray(1 To WsCount) If ActiveWorkbook.ProtectStructure Then

MsgBox https://www.360docs.net/doc/8f12037820.html, & " 被保护，不能进行排序，请解除保护后排序", _

vbCritical, "不能排序工作表"

Exit Sub

End If

For Each Ws In ActiveWorkbook.Worksheets

t = t + 1

WsArray(t) = https://www.360docs.net/doc/8f12037820.html,

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 https://www.360docs.net/doc/8f12037820.html,ments

t = t + 1

Next Flag

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

Sub CountComment()

Dim Flag As Range

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

For Each Flag In https://www.360docs.net/doc/8f12037820.html,edRange

On Error Resume Next

t = https://www.360docs.net/doc/8f12037820.html,ment.Text

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(https://www.360docs.net/doc/8f12037820.html,ments.Count) For i = 1 To https://www.360docs.net/doc/8f12037820.html,ments.Count

Set a(i - 1) = https://www.360docs.net/doc/8f12037820.html,ments(i).Parent

Next i

Set Flag = a

Flag.Select

End Sub

Sub selectcomment()

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

Cells.SpecialCells(xlCellTypeComments).Select

End Sub

Sub 显示或隐藏批注()

Dim Flag As Comment

For Each Flag In https://www.360docs.net/doc/8f12037820.html,ments

If Flag.Visible = True Then

Flag.Visible = False

Else

Flag.Visible = True

End If

Next Flag

End Sub

Sub DisHideComment()

'利用application的displaycommentindicator属性来显示隐藏批注'Indicator表示批注的标识符

If Application.DisplayCommentIndicator = xlCommentAndIndicator Then Application.DisplayCommentIndicator = xlCommentIndicatorOnly

Else

Application.DisplayCommentIndicator = xlCommentAndIndicator

End If

End Sub

Sub 输出所有批注()

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

'这里使用https://www.360docs.net/doc/8f12037820.html,ment.text返回批注中的内容

Dim Flag As Comment

Dim t As Integer

i = 1

With Worksheets("Sheet2")

.Cells.Clear

.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) = Flag.Parent.Address

.Cells(i, 3) = https://www.360docs.net/doc/8f12037820.html,ment.Text

Next Flag

.Columns("B:B").EntireColumn.AutoFit

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

.Cells.EntireRow.AutoFit

End With

End Sub

Sub 改变批注颜色()

Dim Flag As Comment

For Each Flag In https://www.360docs.net/doc/8f12037820.html,ments

Flag.Shape.Fill.ForeColor.SchemeColor = Int((80) * Rnd + 1) '1-80 Flag.Shape.TextFrame.Characters.Font.ColorIndex = Int((56) * Rnd + 1) '1-56

Next Flag

End Sub

Sub 添加批注()

Dim Flag As Range

On Error Resume Next

For Each Flag In ActiveSheet.Range("g8:i17")

t = t + 1

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

+ Chr(10) & Date

Next Flag

End Sub

Sub test()

MsgBox ActiveSheet.Range("g8").Comment.Author

End Sub

Sub 删除批注()

Dim Flag As Range

For Each Flag In ActiveSheet.Range("g8:i17")

https://www.360docs.net/doc/8f12037820.html,ment.Delete

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区域中的一个单元格值

'当application.volatile true时，表示易失性函数

Application.Volatile FlagBoolean

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

UnderstandVolatile = Region(Int(Rnd() * (Region.Count) + 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 = Application.WorksheetFunction.Transpose(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 = VBA.StrReverse(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 = VBA.Mid$(Mstring, i, 1)

Mcode = VBA.Asc(SngString)

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

If IsMissing(Mboolean) Or Mboolean = True Then

If Mcode >= 97 And Mcode <= 122 Then

AimString = AimString & VBA.Chr(Mcode - 32)

Else

AimString = AimString & SngString

End If

Else

If Mcode >= 65 And Mcode <= 90 Then

AimString = AimString & VBA.Chr(Mcode + 32)

Else

AimString = AimString & SngString

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 = VBA.UCase$(Mstring) Else

AlUcLcase1 = VBA.LCase$(Mstring)

End If

End Function

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

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

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

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

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

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

With Application.FileSearch

.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 = ThisWorkbook.Path & "\" FileStyle = "*.txt"

With Application.FileSearch

.LookIn = FilePath

.Filename = FileStyle

.Execute

If .FoundFiles.Count = 0 Then

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

Exit Sub

End If

For Each fs In .FoundFiles

Call EveryText1(fs)

Next fs

End With

End Sub

Sub EveryText(fs)

Workbooks.OpenText 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.Clear

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

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

i = i + 1

.Cells(i, 1) = i - 1

.Cells(i, 2) = fs

.Cells.Columns.AutoFit End With

End Sub

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

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

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

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

代码如下:

Sub 填充单元格()

Dim StartTime As Long

StartTime = Timer

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

Const cols = 200

With ActiveWorkbook.ActiveSheet

.Cells.Clear

For i = 1 To cols

.Cells(1, i) = i

Next i

.Cells.Columns.AutoFit 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 ActiveWorkbook.ActiveSheet

.Cells.Clear

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

.Cells.Columns.AutoFit End With

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

End Sub

Sub 填充单元格行()

Dim Marray()

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

Dim StartTime As Long

Application.ScreenUpdating = False StartTime = Timer

Const Row = 40000

ReDim Marray(1 To Row)

Cells.Clear

For i = 1 To Row

Marray(i) = i

Next i

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

Application.WorksheetFunction.Transpose(Marray)

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

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

Application.ScreenUpdating = True MsgBox "共填充了:" & Row & "行" & vbCr & "利用数组赋值得时间为:" & Format(Timer - StartTime, "0.00") & "秒"

End Sub

Sub 填充单元格行1()

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

Dim StartTime As Long

Application.ScreenUpdating = False StartTime = Timer

Const Row = 40000

Cells.Clear

For i = 1 To Row

Cells(i, 1) = i

Next i

Application.ScreenUpdating = True MsgBox "共填充了:" & Row & "行" & vbCr & "在循环中引用对象，直接赋值得时间为:" & Format(Timer - StartTime, "0.00") & "秒"