Sub 获取所有错误类型编码及含义()  '人工造成错误并获取错误信息
  On Error Resume Next  '错误时继续执行
  Dim arr(), i As Integer
  ReDim arr(1 To 1000, 1 To 2)  '声明一个二维数组，1000行2列
  Range("A1:B1") = Array("错误ID", "错误描述(单击查看详细描述)")  '标题赋值
  Range("A1:B1").Interior.ColorIndex = 3  '添加背景色
  VBA.Err.Raise 1   ' 故意产生运行时错误，方便后面的操作
  Cells(2, 1) = 1        '错误编号
  Cells(2, 2) = Err.Description  '错误类型
  For i = 2 To 1000      '提取2到1000之间的错误类型
    VBA.Err.Raise i    '产生一个编号为i的错误（其中有重复）
    '如果其错误类型不和编号1相同则取其编号与错误描述
    If Error(i) <> "应用程序定义或对象定义错误" Then
      arr(i + 1, 1) = Err.Number  '将错误编号存入数组
      arr(i + 1, 2) = Err.Description  '将错误描述存入数组
    End If
    Err.Clear  '清除错误，方便取下一个错误的相关信息
  Next i
  Range("A3:B1001") = arr  '将数组写入单元格
  Columns("A:B").AutoFit  '自动调整列宽
  '将A1:A1001中空单元格整行删除
  Range("A1:A1001").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target
As Range)
  If Target.Column = 2 Then '仅在选择第二列时执行
    On Error Resume Next '防错
    Err.Raise Target(1).Offset(0, -1) '产生一个错误，错误号为A列的值
    Application.Help Err.HelpFile, Err.HelpContext '打开对应的帮助文件
  End If
End Sub

Sub 获取所有错误类型编码及含义2()  '不产生错误，而利用Error函数来获取错误信息
  Dim arr(), i As Integer
  ReDim arr(1 To 1000, 1 To 2)  '声明一个二维数组，1000行5列
  Range("A1:B1") = Array("错误ID", "错误描述(单击查看详细描述)")  '标题赋值
  Range("A1:B1").Interior.ColorIndex = 3  '添加背景色
  Cells(2, 1) = 1           '错误编号
  Cells(2, 2) = Error(1)   '错误类型
  For i = 2 To 1000      '提取2到1000之间的错误类型
    '如果其错误类型不和编号1相同则取其编号与错误描述
    If Error(i) <> "应用程序定义或对象定义错误" Then
      arr(i + 1, 1) = i  '将错误编号存入数组
      arr(i + 1, 2) = Error(i)  '将错误描述存入数组
    End If
  Next i
  Range("A3:B1001") = arr  '将数组写入单元格
  Columns("A:B").AutoFit  '自动调整列宽
  '将A1:A1001中空单元格整行删除
  Range("A1:A1001").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

Sub 每个班求平均()  '对每个班级每个人员计算平均成绩，且报告每个最差成绩（罗列每一次
错误信息的技术应用）
  Dim ShtCount As Byte, RowCount As Byte, total, MinValue As Byte, ErrStr As String
  On Error GoTo err  '出现错误时执行Err标签后的语句
  For ShtCount = 1 To 5  '循环五次'如果A列空白则中转到Line标签
    If WorksheetFunction.CountA(Sheets(ShtCount).[a:a]) = 0 Then GoTo Line
    For RowCount = 2 To Sheets(ShtCount).Cells(Rows.Count, 1).End(xlUp).
    Row  '循环每一行
      '在第五列返回平均值，即每个学生的平均成绩
      Sheets(ShtCount).Cells(RowCount, 5) = WorksheetFunction.Average
      (Sheets(ShtCount).Cells(RowCount, 4).Offset(0, -2).Resize(1, 3))
      '记录每个学生的总成绩
      total = Application.Sum(Sheets(ShtCount).Cells(RowCount, 4).Offset
      (0, -2).Resize(1, 3))
      If MinValue = 0 Then MinValue = total
      '如果MinValue变量为0则赋值第一个总成绩
      If MinValue > total Then MinValue = total
      '如果变量大于总成绩则对变量赋值为总成绩
    Next RowCount
    '记录每个班级（工作表名）的最小总成绩
    TempStr = TempStr & Chr(10) & Sheets(ShtCount).Name & MinValue
    MinValue = 0  '循环完一个工作表后将变量重置为0
Line:
  Next
  MsgBox TempStr  '程序结束前报告每个班最小总成绩
  If i > 0 Then MsgBox "出错" & i & "次，原因分别为：" & ErrStr
  '如果有错误则报告次数和原因
  Exit Sub  '退出程序
err:
  Application.StatusBar = err.Description  '在状态栏显示错误原因
  i = i + 1  '累加变量，该变量表示出错次数
  ErrStr = ErrStr & Chr(10) & err.Description  '将所有错误串连成一个字符串
  err.Clear  '清除当前错误
  Resume Next    '执行下一句代码
End Sub

Sub 获取平方根1()
    Dim Value As Long
    Value = InputBox("请输入数值：", "待开方之数值", 0)
    ActiveCell.Value = Sqr(Value)
End Sub

Sub 获取平方根2()    '解决单击“取消”按钮问题
    Dim Value As Variant
    Value = InputBox("请输入数值：", "待开方之数值", 0)
    If Len(Value) = 0 Then Exit Sub
    ActiveCell.Value = Sqr(Value)
End Sub

Sub 获取平方根3()    '解决负数问题
    Dim Value
    Value = InputBox("请输入数值：", "待开方之数值", 0)
    If Len(Value) = 0 Then Exit Sub
    If Not Value < 0 Then ActiveCell.Value = Sqr(Value) Else MsgBox
    "不能小于0"
End Sub

Sub 获取平方根4()    '解决文字问题
    Dim Value
Value = InputBox("请输入数值：", "待开方之数值", 0)
If Len(Value) = 0 Then Exit Sub
    If VBA.IsNumeric(Value) Then
        If Not Value < 0 Then ActiveCell.Value = Sqr(Value) Else MsgBox "
        不能小于0"
    Else
        MsgBox "不能输入文本", 64, "提示"
    End If
End Sub

Sub 获取平方根5()    '解决图表问题
    Dim Value
    If TypeName(ActiveSheet) = "Chart" Then MsgBox "不要选择图表": Exit Sub Value = InputBox("请输入数值：", "待开方之数值", 0)
If Len(Value) = 0 Then Exit Sub
    If VBA.IsNumeric(Value) Then
      If Not Value < 0 Then ActiveCell.Value = Sqr(Value) Else MsgBox "
      不能小于0"
    Else
      MsgBox "不能输入文本", 64, "提示"
    End If
End Sub

Sub 获取平方根6()    '解决工作表保护问题
    Dim Value
    If TypeName(ActiveSheet) = "Chart" Then MsgBox "不要选择图表": Exit Sub
    If ActiveSheet.ProtectContents Then MsgBox "工作表已保护": Exit Sub
Value = InputBox("请输入数值：", "待开方之数值", 0)
If Len(Value) = 0 Then Exit Sub
    If VBA.IsNumeric(Value) Then
      If Not Value < 0 Then ActiveCell.Value = Sqr(Value) Else MsgBox "
      不能小于0"
    Else
      MsgBox "不能输入文本", 64, "提示"
    End If
End Sub

Sub 获取平方根7()    '解决数组区域问题
    Dim Value
    If TypeName(ActiveSheet) = "Chart" Then MsgBox "不要选择图表": Exit Sub
    If ActiveSheet.ProtectContents Then MsgBox "工作表已保护": Exit Sub
Value = InputBox("请输入数值：", "待开方之数值", 0)
If Len(Value) = 0 Then Exit Sub
    If VBA.IsNumeric(Value) Then
      On Error Resume Next
      Debug.Print ActiveCell.CurrentArray
      If Err = 0 Then MsgBox "请不要选择数组区域": Exit Sub
      If Not Value < 0 Then ActiveCell.Value = Sqr(Value) Else MsgBox "
      不能小于0"
  Else
      MsgBox "不能输入文本", 64, "提示"
  End If
End Sub

Sub 获取平方根8()    '解决所有问题
    On Error Resume Next
    ActiveCell.Value = Sqr(Application.InputBox("请输入数值：", "开平方",
    0, , , , , 1))
End Sub

Sub 按月创建新表()       '创建一个月的工作表
  Dim Date1 As Date    '声明一个日期变量
  Date1 = #1/15/2009#  '指定基数
'从基数日期开始，到下月同日的前一天，
  For i = Date1 * 1 To DateAdd("m", 1, Date1) * 1 - 1
    Sheets.Add after:=Sheets(Sheets.Count)    '创建一个新表，放到末尾
    ActiveSheet.Name = Format(i, "mm月dd日")  '命名为日期
  Next
End Sub

Sub 按月创建新表2()      '创建一个月的工作表
  Dim Date1 As Date    '声明一个日期变量
  Date1 = #1/15/2009#  '指定基数
  On Error Resume Next'错误时继续执行下一句
  '从基数日期开始，到下月同日的前一天
  For i = Date1 * 1 To DateAdd("m", 1, Date1) * 1 - 1
    Debug.Print Sheets(Format(i, "mm月dd日")).Name '输出工作表名
    '如果无错误（表示存在名为Format(i, "mm月dd日")的工作表），则执行line后面的语句
    If Err = 0 Then GoTo line
    Sheets.Add after:=Sheets(Sheets.Count)     '创建一个新表，放到末尾
    ActiveSheet.Name = Format(i, "mm月dd日")   '命名为日期
    line: '指定一个标签，在指定条件时可以跳转至此处
  Next
End Sub

'定义一个函数，判断单元格是否有数据有效性设置，结果为True或者False
Function IsValidation(rng As Range) As Boolean
  On Error Resume Next  '错误时继续执行
  Dim Str As String
  '提取单元格的有效性公式，如果参数为区域则取左上角单元格
  Str = rng(1).Validation.Formula1
  IsValidation = (Err.Number = 0)  '公式结果由是否产生错误来决定
End Function