第8章函数的使用代码超实用VBA.docx

1、第8章 函数的使用代码超实用VBA第8章 函数的使用范例119 使用时间和日期函数119-1 计算程序运行时间Sub MyTime() Dim i As Integer Dim StartTime As Single Dim EndTime As Single StartTime = Timer For i = 1 To 10000 Cells(1, 1) = i Next EndTime = Timer - StartTime MsgBox 程序运行时间： & Format(EndTime, 0.00) & 秒End Sub119-2 获得当月的最后一天Sub Endday() Dim En

2、dday As Byte Endday = Day(DateSerial(Year(Date), Month(Date) + 1, 0) MsgBox 当月最后一天是 & Month(Date) & 月 & Endday & 号End Sub119-3 计算某个日期为星期几Sub Myweekday() Dim StrDate As String Dim Myweekday As String StrDate = InputBox(请输入日期：) If Len(StrDate) = 0 Then Exit Sub If IsDate(StrDate) Then Select Case Week

3、day(StrDate, vbSunday) Case vbSunday Myweekday = 星期日 Case vbMonday Myweekday = 星期一 Case vbTuesday Myweekday = 星期二 Case vbWednesday Myweekday = 星期三 Case vbThursday Myweekday = 星期四 Case vbFriday Myweekday = 星期五 Case vbSaturday Myweekday = 星期六 End Select MsgBox DateValue(StrDate) & & Myweekday Else Msg

4、Box 请输入正确格式的日期! End IfEnd Sub119-4 计算两个日期的时间间隔Sub DateInterval() Dim StrDate As String StrDate = InputBox(请输入日期：) If Len(StrDate) = 0 Then Exit Sub If IsDate(StrDate) Then MsgBox DateValue(StrDate) & Chr(13) & 距离今天有 _ & Abs(DateDiff(d, Date, StrDate) & 天 Else MsgBox 请输入正确格式的日期! End IfEnd Sub119-5 获得

5、指定时间间隔的日期Sub MyDateAdd() Dim StrDate As String StrDate = Application.InputBox(Prompt:=请输入间隔的天数：, Type:=1) If StrDate = False Then Exit Sub MsgBox StrDate & 天后的日期是 & DateAdd(d, StrDate, Date)End Sub119-6 格式化时间和日期Sub TimeDateFormat() Dim Str As String Str = Format(Now, Medium Time) & Chr(13) _ & Forma

6、t(Now, Long Time) & Chr(13) _ & Format(Now, Short Time) & Chr(13) _ & Format(Now, General Date) & Chr(13) _ & Format(Now, Long Date) & Chr(13) _ & Format(Now, Medium Date) & Chr(13) _ & Format(Now, Short Date) MsgBox StrEnd Sub范例120 使用字符串处理函数Sub StrFunctions() Dim Str As String Str = Use String Func

7、tions MsgBox 原始字符串： & Str & Chr(13) _ & 字符串长度： & Len(Str) & Chr(13) _ & 左边8个字符： & Left(Str, 8) & Chr(13) _ & 右边6个字符： & Right(Str, 6) & Chr(13) _ & Str出现在字符串的第 & InStr(Str, Str) & 位 & Chr(13) _ & 从左边第5个开始取6个字符： & Mid(Str, 5, 6) & Chr(13) _ & 转换为大写： & UCase(Str) & Chr(13) _ & 转换为小写： & LCase(Str) & Chr

8、(13)End Sub范例121 判断表达式是否为数值Sub MyNumeric() Dim r As Integer Dim rng As Range Dim Ynumber As String Dim Nnumber As String r = Cells(Rows.Count, 1).End(xlUp).Row For Each rng In Range(A1:A & r) If IsNumeric(rng) Then Ynumber = Ynumber & rng.Address(0, 0) & vbTab & rng & vbCrLf Else Nnumber = Nnumber &

9、 rng.Address(0, 0) & vbTab & rng & vbCrLf End If Next MsgBox 数值单元格： & vbCrLf & Ynumber & vbCrLf _ & 非数值单元格： & vbCrLf & NnumberEnd Sub范例122 自定义数值格式Sub CustomDigitalFormat() Dim MyNumeric As Double Dim Str As String MyNumeric = 123456789 Str = Format(MyNumeric, 0.00) & vbCrLf _ & Format(MyNumeric, 0%)

10、 & vbCrLf _ & Format(MyNumeric, #,#0.00) & vbCrLf _ & Format(MyNumeric, $#,#0.00) & vbCrLf _ & Format(-(MyNumeric), ￥#,#0.00;(￥#,#0.00) MsgBox StrEnd Sub范例123 四舍五入运算Sub Rounding() MsgBox Round(4.56789, 2)End SubSub AmendmentsRound() MsgBox Round(2.5 + 0.0000001)End SubSub SheetsRound() MsgBox Applic

11、ation.Round(2.5, 0)End Sub范例124 使用Array函数创建数组Option Base 1Sub Myarr() Dim arr As Variant Dim i As Integer arr = Array(王晓明, 吴胜玉, 周志国, 曹武伟, 张新发, 卓雪梅, 沈煜婷, 丁林平) For i = LBound(arr) To UBound(arr) Cells(i, 1) = arr(i) NextEnd Sub范例125 将字符串按指定的分隔符分开Sub Splitarr() Dim Arr As Variant Arr = Split(Cells(1, 2

12、), ,) Cells(1, 1).Resize(UBound(Arr) + 1, 1) = Application.Transpose(Arr)End Sub范例126 使用动态数组去除重复值Sub Splitarr() Dim Splarr() As String Dim Arr() As String Dim Temp() As String Dim r As Integer Dim i As Integer On Error Resume Next Splarr = Split(Range(B1), ,) For i = 0 To UBound(Splarr) Temp = Filte

13、r(Arr, Splarr(i) If UBound(Temp) 0 Then r = r + 1 ReDim Preserve Arr(1 To r) Arr(r) = Splarr(i) End If Next Range(A1).Resize(r, 1) = Application.Transpose(Arr)End Sub范例127 调用工作表函数127-1 使用Sum函数求和Sub SumCell() Dim r As Integer Dim rng As Range Dim Dsum As Double r = Cells(Rows.Count, 1).End(xlUp).Row

14、Set rng = Range(A1:F & r) Dsum = Application.WorksheetFunction.Sum(rng) MsgBox rng.Address(0, 0) & 单元格的和为 & DsumEnd Sub127-2 查找工作表中最大、最小值Sub FindMaxAndMin() Dim r As Integer Dim Rng As Range, MyRng As Range Dim MaxCount As Integer, MainCount As Integer Dim Mymax As Double, Mymin As Double r = Cells(

15、Rows.Count, 1).End(xlUp).Row Set MyRng = Range(A1:J & r) For Each Rng In MyRng If Rng.Value = WorksheetFunction.max(MyRng) Then Rng.Interior.ColorIndex = 3 MaxCount = MaxCount + 1 Mymax = Rng.Value ElseIf Rng.Value = WorksheetFunction.min(MyRng) Then Rng.Interior.ColorIndex = 5 MainCount = MainCount

16、 + 1 Mymin = Rng.Value Else Rng.Interior.ColorIndex = 0 End If Next MsgBox 最大值是： & Mymax & ，共有 & MaxCount & 个。 _ & Chr(13) & 最小值是： & Mymin & ，共有 & MainCount & 个。End Sub127-3 不重复值的录入Private Sub Worksheet_Change(ByVal Target As Range) With Target If .Column 1 Or .Count 1 Then Exit Sub If WorksheetFunc

17、tion.CountIf(Range(A:A), .Value) 1 Then .Select MsgBox 不能输入重复的数据!, 64 Application.EnableEvents = False .Value = Application.EnableEvents = True End If End WithEnd Sub范例128 个人所得税自定义函数Public Function PITax(Income, Optional Threshold) As Double Dim Rate As Double Dim Deduction As Double Dim Taxliabilit

18、y As Double If IsMissing(Threshold) Then Threshold = 2000 Taxliability = Income - Threshold Select Case Taxliability Case 0 To 500 Rate = 0.05 Deduction = 0 Case 500.01 To 2000 Rate = 0.1 Deduction = 25 Case 2000.01 To 5000 Rate = 0.15 Deduction = 125 Case 5000.01 To 20000 Rate = 0.2 Deduction = 375

19、 Case 20000.01 To 40000 Rate = 0.25 Deduction = 1375 Case 40000.01 To 60000 Rate = 0.3 Deduction = 3375 Case 60000.01 To 80000 Rate = 0.35 Deduction = 6375 Case 80000.01 To 10000 Rate = 0.4 Deduction = 10375 Case Else Rate = 0.45 Deduction = 15375 End Select If Taxliability 0 Then If Not ExistSh(Sh)

20、 Then MsgBox 对不起, & Sh & 工作表不存在! Else Sheets(Sh).Select End If End IfEnd Sub范例132 查找指定工作簿Function ExistWorkbook(WbName As String) As Boolean Dim Wb As Workbook On Error Resume Next Set Wb = Workbooks(WbName) If Err = 0 Then ExistWorkbook = True Set Wb = NothingEnd FunctionSub NotWorkbook() Dim Wb As

21、 String Wb = InputBox(请输入工作簿名称：) If Len(Wb) 0 Then If Not (ExistWorkbook(Wb) Then MsgBox Wb & 工作簿没有打开! End If End IfEnd Sub【代码解析】自定义ExistWorkbook函数判断指定名称的工作簿是否打开。第5行代码，判断第4行代码是否出错，如果出错，则表示指定名称的工作簿没有打开，自定义ExistWorkbook函数返回False。使用自定义ExistWorkbook函数可以判断指定名称的工作簿是否打开，范例代码如下：#001 Sub NotWorkbook()#002 Di

22、m Wb As String#003 Wb = InputBox(请输入工作簿名称：)#004 If Len(Wb) 0 Then#005 If Not (ExistWorkbook(Wb) Then#006 MsgBox Wb & 工作簿没有打开!#007 End If#008 End If#009 End Sub范例133 取得应用程序的安装路径Function GetSetupPath(AppName As String) Dim Wsh As Object Set Wsh = CreateObject(Wscript.Shell) GetSetupPath = Wsh.RegRead(HKEY_LOCAL_MACHINESoftware _ & MicrosoftWindowsCurrentVersionApp Paths _ & AppName & Path) Set Wsh = NothingEnd FunctionSub WinRARPath() MsgBox GetSetupPath(WinRAR.exe)End Sub