VBA——基础代码

第二章，第三章

ActiveCell.Font.Bold = True

Application.ThisWorkbook.Sheets("Sheet1").Range("A1").Select

Range("A1").Select

Worksheets(1).Select
Worksheets("Mysheet").Select

Workbooks("MyData.xlsx").Worksheets("Mysheet").Select


MsgBoxRange("A1").address(RowAbsolute:=True, Columnsolute:=True)

ActiveCell.Value =1

ActiveCell.ClearContents
ActiveSheet.Cells.ClearContents

Msg ActiveWorkbook.FullName

ActiveCell.Value = 1 

ActiveCell.ClearContents

MsgBox ActiveSheet.Name  #显示活动工作表的名称

#获取活动工作簿的名称和目录路径
Sub my_exercise():
      MsgBox ActiveWorkbook.FullName
End Sub

Selection.Value = 12 #用单个值充满单元格区域

ActiveWindow.RangeSelection.Value = 12 #选中的多个cell填充为12

MsgBox ActiveWindow.RangeSelection.Count #数自己选了多少的单元格

Sub my_exercise():
      Range("A1").Value = 2
      Range("A1").Select
      Range("A1").Copy
      ActiveSheet.Paste Destination:=Range("B1")
End Sub

Range对象
	  Range("A3").Value = 7
      ActiveSheet.Range("A4").Value = 8
      Worksheets("sheet5").Range("A5:A8").Value = 9
      Range("B1:B10") = 7
      range("C1","C10")=7
      range("B3"."C4")=7
      range("A2:A5","B3:B4") =7

Cell对象
		Worksheets("sheet5").Cells(3, 7) = 7
		Range("A1:A10").Cells(5) = 1000
		ActiveSheet.Cells.ClearContents

ActiveCell.Formula = 3
ActiveCell =1
ActiveCell.Offset(1, 1) = 10

Sub msgbox_test():
      Dim ans As Long
      ans = MsgBox("continue?", vbYesNo + vbQuestion, "Tell me")
      '把结果赋给ans
      
      If ans = vbNo Then
            Exit Sub
      End If
      
End Sub

With end-With适合对一个对象改变多种属性或方法时使用。
Sub ChangeFont1():
      Selection.Font.Name = "Cambria"
      Selection.Font.Bold = "True"
      Selection.Font.Italic = "True"
End Sub


Sub ChangeFont2():
      With Selection.Font
            .Name = "Cambria"
            .Bold = "True"
            .Italic = "True"
      End With
End Sub
'推荐ChangeFont2 , 只引用了一次对象，1引用了多次对象，2运行速度更快。

For-Each next语句
Sub CoutSheets():
      Dim Item As Worksheet
      For Each Item In ActiveWorkbook.Worksheets
            MsgBox Item.Name
            '依次显示sheets名称
      Next Item
End Sub

实例：使用For  next 遍历集合中的所有对象，并计算隐藏窗口的总数。
Sub counts():
      For i = 1 To Sheets.Count:
            If Sheets(i).Visible <> xlSheetVisible Then
                  lngNum = lngNum + 1
            End If
      Next
      MsgBox lngNum & " unvisible windows."
End Sub

实例：将所选的单元格的字母转化为大写，数字不表。
Sub change_Big_write():
      Dim cell As Range
      For Each cell In Selection
            cell.Value = UCase(cell.Value)
      Next cell
End Sub

GoTo语句——通常在使用错误处理时使用
Sub GoToDemo():
      UserName = InputBox("Enter Your Name:")
      If UserName <> "Howard" Then
            GoTo WrongName
      End If
      MsgBox ("Welcome  Howard....")
      Exit Sub
      
WrongName:
      MsgBox ("Sorry. Only Howard can run this work.")
      
End Sub

!   exit sub 不同于end sub
!   msgbox()

if then语句
Sub Greetme():
      If Time < 0.5 Then
            MsgBox ("Goodmoring")
            MsgBox Time  '11:18:23  <0.5????
      Else
            If Time >= 0.5 And Time < 0.75 Then
                  MsgBox ("Good Evening")
            End If
      End If
End Sub

'select case 语句：适用于三个或多个选项
特点：只要发现了TRUE情况，就退出来Case，提高了效率
Sub Greetme():
     Dim quantity As Variant
     Dim discount As Double
     quantity = InputBox("Enter Quantity：")
     Select Case quantity
            Case ""
                  Exit Sub
            Case 0 To 24
                  discount = 0.1
            Case 25 To 49
                  discount = 0.15
            Case 50 To 74
                  discount = 0.2
            Case Is > 75
                  discount = 0.25
      End Select
      MsgBox ("Discount: " & discount)
End Sub

Sub Greetme():
     Dim quantity As Variant
     Dim discount As Double
     quantity = InputBox("Enter Quantity：")
     Select Case quantity
            Case "":   Exit Sub
            Case 0 To 24: discount = 0.1
            Case 25 To 49: discount = 0.15
            Case 50 To 74: discount = 0.2
            Case Is > 75: discount = 0.25
      End Select
      MsgBox ("Discount: " & discount)
End Sub

'for-next语句
Sub Greetme():
      Dim rownum As Long
      For rownum = 10 To 2 Step -2:
      '删除要倒着删除，正删，删除了第二行，第3->2,4->3,5->4,删除第四行，实际删除的是第五行
            Rows(rownum).Delete
      Next rownum
End Sub

'for-next结构
Sub max_test():
      Sheets("8").Range("A:A").Find(Application.WorksheetFunction.Max(Sheets("8").Range("A:A"))).Activate
      
'      Dim maxvalue As Double
'      Dim row As Long
'      maxval = Application.WorksheetFunction.Max(Sheets("8").Range("A:A"))
'      For row = 1 To 1048576
'            MsgBox (Sheets("8").Cells(row, 1))
'            If Sheets("8").Cells(row, 1).Value = maxval Then
'                  Exit For
'            End If
'      Next row
'      MsgBox "Max value is in Row:" & row
'      Sheets("8").Cells(row, 1).Activate
End Sub

！ exit for 退出for

'do  while  loop
'while 放在前面，可能从来不执行循环的内容
'while放在后面，至少执行一次循环的内容
Sub enterdates1():
      Dim thedate As Date
      thedate = DateSerial(Year(Date), Month(Date), 1)
      Do While Month(thedate) = Month(Date)
            ActiveCell = thedate
            thedate = thedate + 1
            ActiveCell.Offset(1, 0).Activate
      Loop
End Sub

Sub enterdates2():
      Dim thedate As Date
      thedate = DateSerial(Year(Date), Month(Date), 1)
      Do
            ActiveCell = thedate
            thedate = thedate + 1
            ActiveCell.Offset(1, 0).Activate
      Loop While Month(thedate) = Month(Date)
End Sub
运行结果相同

do until与do while 结构相似，区别在于条件控制一个正向，一个反向。

'do  until
Sub enterdates4():
      Dim thedate As Date
      thedate = DateSerial(Year(Date), Month(Date), 1)
      Do Until (Month(thedate) <> Month(Date))
            ActiveCell = thedate
            thedate = thedate + 1
            ActiveCell.Offset(1, 0).Activate
      Loop
End Sub

Sub enterdates3():
      Dim thedate As Date
      thedate = DateSerial(Year(Date), Month(Date), 1)
      Do
            ActiveCell = thedate
            thedate = thedate + 1
            ActiveCell.Offset(1, 0).Activate
      Loop Until (Month(thedate) <> Month(Date))
End Sub

while wend——这种循环结构主要是出于兼容性的目的

'while wend
Sub enterdates5():
      Dim thedate As Date
      thedate = DateSerial(Year(Date), Month(Date), 1)
      While (Month(thedate) = Month(Date))
            ActiveCell = thedate
            thedate = thedate + 1
            ActiveCell.Offset(1, 0).Activate
      Wend
End Sub

第四章

'call 函数（）  引用另一个函数
Sub main()
      Dim subtocall As String
      MsgBox (Weekday(Now))
      Select Case Weekday(Now)
            Case 1, 7: subtocall = "WeekEnd"
            Case Else: subtocall = "Daily"
      End Select
            Application.Run subtocall
End Sub

Sub WeekEnd()
      MsgBox ("Today is a weekend")
End Sub

Sub Daily()
      MsgBox ("Today is a weekday")
End Sub

ctril+g == 立即窗口
在立即窗口中输入过程名称，便会执行该过程。

Option Explicit
Sub main()
      Dim file(1 To 3) As String
      Dim i As Integer
      file(1) = "E:\JOB\模板报告\少儿部\最美长安个性化报告_1-5年级\四年级.xlsm"
      file(2) = "E:\JOB\模板报告\少儿部\最美长安个性化报告_1-5年级\三年级.xlsm"
      file(3) = "E:\JOB\模板报告\少儿部\最美长安个性化报告_1-5年级\二年级.xlsm"
      
      For i = 1 To 3
            Call processFile(file(i))  '传递变量
      Next i
      
      ' call processFile("E:\JOB\模板报告\少儿部\最美长安个性化报告_1-5年级\二年级.xlsm")
      '直接传递
End Sub

Sub processFile(thefile)
      Workbooks.Open Filename:=thefile
End Sub

'将参数传递给过程：
'1、通过引用——通过引用传递参数的书法（默认方法），只传递变量的内存地址。对过程中的
'     参数的修改将影响到原始变量
'2、通过数值——通过数值传递参数传递的是原始变量的副本。因此,对过程中参数所做的修改不
'      会影响到原变量

注：用户自定义数据类型的变量传递给过程，必须      通过引用     来传递，通过值传递会报错。
Sub main()
      Dim myvalue As Integer
      myvalue = 12
      Call process(myvalue)    '默认方法
      MsgBox (myvalue)
End Sub

Sub process(youvalue)
      youvalue = youvalue * 10
End Sub

修改：在变量前加上ByVal，输出为12. 
Sub process(ByVal youvalue)
      youvalue = youvalue * 10
End Sub

! yourvalue 并未声明任何数据类型，默认为variant数据类型。
！更好是定义数据类型 且要匹配。
！当不匹配时，会得到"ByRef参数类型不符"错误。
修改：Sub process(youvalue As Integer)

！公共变量public Monthval as integer ,任何过程都可以访问它，不需要作为参数进行传递。

• 发生错误则中断 VBA会忽略错误处理代码。通常使用"遇到未处理的错误时中断"
  
• 捕获错误
  • 使用On Error语句指定错误发生时应采取的措施
    1、忽略错误并允许VBA继续执行代码 （On Error Resume Next）
    2、跳转到代码中特殊的错误处理部分 （On Error GoTo ErrorHandler）
    

'错误处理实例：
Sub Selectformulas()
      On Error Resume Next     ' 忽略错误并继续执行代码，防止显示错误消息
      Selection.SpecialCells(xlFormulas).Select
            'SpecialCells方法选中了当前单元格区域选区中的所有单元格，该选区包含返回数字的公式。
            '如果没有符合要求的单元格，VBA会显示1004，未找到单元格。
      If Err.Number <> 0 Then MsgBox ("Error Occured")
            '检查是否存在任何错误
      On Error GoTo 0
End Sub

'错误处理实例：
Sub ErrorDemo()
      On Error GoTo handle      '指定跳到handler标签
      Selection.Value = 123
      Exit Sub           '!!!!如果没有该退出，没有错误也会执行handle，即报错。
      
handle:
      MsgBox ("cannot assign a calue to the selection")
End Sub

Sub checkforfile()
      Dim fileName As String
      Dim fileExists As Boolean
      Dim book As Workbook
      fileName = "Debug.xlsx"
      fileExists = False

      For Each book In Workbooks
            If UCase(book.Name) = fileName Then fileExists = True
      Next book

      If fileExists Then
            MsgBox fileName & " is open "
      Else
            MsgBox fileName & " is not open "
      End If
End Sub

'利用错误捕获消息
Sub CheckFile()
      Dim fileName As String
      Dim x As Workbook
      fileName = "Debug.xlsx"
      
      On Error Resume Next  '忽略错误继续执行代码
      Set x = Workbooks(fileName)  '把工作簿直接赋值给某个对象变量
      If Err = 0 Then
            MsgBox fileName & " is open "
      Else
            MsgBox fileName & " is not open "
      End If
      On Error GoTo 0
End Sub

Function commission(sales)
      Const tier1 = 0.08
      Const tier2 = 0.105
      Const tier3 = 0.12
      Const tier4 = 0.14
      
      Select Case sales
            Case 0 To 9999.99: commission = sales * tier1
            Case 10000 To 19999.99: commission = sales * tier2
            Case 20000 To 39999.99: commission = sales * tier3
            Case Is >= 40000: commission = sales * tier4
End Function

Option Explicit

Function DRAWONE(Rng As Variant, Optional Recalc As Variant = False)
      Application.Volatile.Recalc
      DRAWONE = Rng(Int(Rng.Count) * Rnd + 1)
End Function

Function Monthnames(Optional Mindex)
' optional 可选参数
'功能1：如果省略了这个参数，函数将返回一个包含月份的水平方向的数组
'功能2 :
      Dim AllNames As Variant
      Dim MonthVal As Long
      
      Monthnames = 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
                        MonthVal = ((Mindex - 1) Mod 12)
                        Monthnames = AllNames(MonthVal)
                  Case Is <= 0
                        Monthnames = Application.Transpose(AllNames)
            End Select
      End If
End Function

'  sum计算函数，但参数只能是具体的值，不能是单元格
Option Explicit
Function simpilesum(ParamArray arglist() As Variant) As Double
      Dim arg As Variant
      Dim sumpilesum As Variant
      For Each arg In arglist
            sumpilesum = sumpilesum + arg
      Next arg
      simpilesum = sumpilesum
End Function

'my_sum  计算单元格内的值的和
Function my_sum(ParamArray arglist() As Variant) As Double

      Dim cell As Range
      For Each arg In arglist
            For Each cell In arg
                  my_sum = my_sum + cell
            Next cell
      Next arg
      
End Function
'测试：当单元格是非数值的其他元素时，运行失败。
空格可以运行，字符串运行失败。