3.编写sub过程及开发函数——《Excel VBA 程序开发自学宝典》

3.1 编写sub过程

实例：

---

Sub 建立10个表()

If sheets.count>=10 then exit sub

Sheets.add , sheets(sheets.count) , 1

Call 建立10个表     ‘过程递归

End sub

---

Sub 选取统计()

Dim msg as string

Msg = “单元格个数：” & selection.count & chr(10)

Msg = msg & “数字个数：” & worksheetfunction.count(selection) & chr(10)

Msg = msg & “非空单元格：” & worksheetfunction.counta(selection) & chr(10)

Msg = msg & “空白单元格个数：” & worksheetfunction.countblank(selection) & chr(10)

Msg = msg & “选区之和：” & worksheetfunction.sum(selection)

Msgbox msg , 64, “选区统计”

End sub

---

3.2 关于过程的参数

实例：

---

Sub 转换(target)      ‘首字母转大写

Selection(1) = strconv(target , vbpropercase)

End sub

Private sub worksheet_selectionchange(byval target as range)    ‘指定工作表；byval表示该参数按值传递，过程不改变变量本身的值

Call 转换(target(1))

End sub

---

Sub 姓名(name as string)      ‘单参数过程

Dim I as byte , rng as range

For I = 1 to sheets.count

If thisworkbook.sheets(i).name = “许可人员列表” then : goto OK

Next i

Msgbox “不存在“许可人员列表”” , 64

Exit sub

OK:

If len(name)<2 or len(name)>4 then msgbox “长度只能是2到4，请重新输入”,64:

Exit sub

Set rng = thisworkbook.sheets(“许可人员列表”).range(“A1:A10”).find(name)

If rng is nothing then msgbox “你无操作权限” else msgbox “你具有操作权限”

End sub

Sub 确认权限一()     ‘手工制定姓名

Call 姓名(application.inputbox(“请输入您的姓名”,”确认权限”,,,,,2))

End sub

Sub 确认权限二()      ‘以当前表A1的值进行判断

Call 姓名(activesheet.range(“A1”))

End sub

Sub 确认权限三()       ‘以office安装用户名进行判断

Call 姓名(application.username)

End sub

---

3.3 开发自定义函数

实例：

---

‘返回有公式的单元格地址

Function FunAdd()   '申明函数，无参数

Dim rng as range, cell as range

for each rng in activesheet.usedrange  '遍历当前表的已用区域

if rng.hasformula then  '如果单元格有公式

if rng.address<>application.thiscell.adress then   '如果变量rng的地址不等于当前公式所在单元格的地址，为了防止函数返回的地址包含本公式的单元格

if cell is nothing then   '如果变量cell未初始化

set cell=rng   '将变量rng赋值给变量cell

else

set cell= application.union(cell,rng)   '将变量cell和rng所代表的两个单元格对象合并为一个对象，赋值给cell

end if

end if

end if

next rng

if cell is nothing then FunAdd = "" else FunAdd = cell.address(0,0)   '如果变量cell未初始化（即未找到符合条件的单元格）那么返回空文本，否则返回cell的地址

end function

---

'建立工作表目录

Function 工作表(Optional 序号) As String     '有一个参数为可选参数，为该工作表的序号

application.volatile    '声明为易失性函数

if ismissing(序号) then 序号=activesheet.index    '如果未输入参数，则赋予变量序号为当前表的地址，index属性是指工作表在所有工作表中的序号（从左向右数）

if 序号>sheets.count then    '如果参数大于工作表数量

工作表=“”

else

工作表=sheets(序号).name     '表名

end if

end function

---

'将“花生15公斤，黄豆234斤，大米20袋"分列，将品名、数量、单位放在不同单元中

Function Breakdown (rng as range , optional style as byte=1) as string   '第一个参数为单元格引用，第二参数表示分列后的第几列

application.volatile

on error resume next   '防错

dim i as integer, str as string   '将单元格的值以逗号分隔符转换为一维数组，再从数组中取字符串赋值给变量str，取值的位置取决于第二参数

str = split(rng.text,",")(worksheetfunction.roundup(style/3,0)-1)   ’split将一个字符串按照”，“为分隔符转换为一个数组

if style mod 3=1 then  '如果第二个参数除以3的余数是1

for i=1 to len(str)

if isnumeric(mid(str,i,1)) then exit function   '如果遇到数字就结束过程

breakdown= breakdown & mid(str,i,1)     '将取出的所有字符串联起来作为函数的返回值

next i

elseif style mod 3=2 then

for i=1 to len(str)

if VBA.isnumeric(mid(str,i,1) or mid(str,i,1)="." then breakdown = breakdown & mid(str,i,1)

next i

elseif style mod 3=0 then

for i=len(str) to 1 step=1

if isnumric(mid(str,i,1)) then exit function

breakdown= mid(str,i,1) & breakdown

next i

end

if err<> then breakdown =""   '如果有错误就返回空白

end function

---

'中国式排名，需要忽略重复值

Function 排名(区域,成绩)     '区域为需要排名的所有成绩，成绩为需要计算排名的该成绩

application.valatile

dim dic as object, rng ,i as integer

set dic=createobject("scripting.dictionary")     '声明字典对象变量，特点是成员不重复

for each rng in 区域

if rng = 成绩 then i=1 else if rng>成绩 then dic(rng*1)=1    '如果rng大于成绩，则将rng的值追加到字典中

next

if i>0 then 排名=dic.count+1 else 排名="超出范围"

end function

---