张亦Excel VBA——基础篇

'张亦Excel VBA——基础篇
'写给每一个想学VBA但又无从下手的人
'由于工作原因，笔者自学了VBA，以下便是学习过程中写的测试样例并做了注释，个人觉得对于有开发基础的朋友来说下面的样例很好理解，如果没有开发基础可能会多用一些时间来学习，其实VBA并不难，关键是要自己动手写。
'本文并无商业目的，仅供大家参考，如果发现有错误或者想一起沟通交流VBA可以访问我的微博：【http://www.weibo.com/zychere】
Option Explicit '强制声明变量
Public str0 As String '声明公共变量

'给变量赋值
Public Sub mysub() '注意：如果声明成private则只能在模块内部调用
    Dim str1 As String '此处定义变量还可以用以下方式：1、Dim str1 As String * 2
                                                     '2、Dim str1$
                                                     '3、Dim str1 As String,str2 as Integer
    str1 = "test" '这里前面省略了"Let"
    Const str2 As Single = 3.14 'str2是常量，值不能修改
    MsgBox str2
End Sub

'一维数组
Public Sub mysub2()
    Dim array1(1 To 50) As String '声明数组，也可以写成Dim array1(50) As String
    array1(1) = "a" '给数组赋值
    
    Dim i As Integer
    For i = 1 To 10 '循环给数组赋值
    array1(i) = i
    MsgBox array1(i)
    Next
End Sub

'二维数组
Public Sub mysub3()
    Dim array1(1 To 10, 1 To 20) As String '定义二维数组也可以写成Dim array1(10,20)
    array1(1, 3) = "二维数组测试"
    MsgBox array1(1, 3)
End Sub

'动态数组、Array函数创建数组、Range对象创建数组、UBound/LBound、Join、Transpose
Public Sub mysub4()
    Dim array1() As String
    Dim n As Long
    n = Application.WorksheetFunction.CountA(range("A:A")) '统计有多少个非空单元格，常用Application方法
    ReDim array1(n) As String
    '-----------------------------------------------------------------------------
    Dim array2() As Variant '不加As Variant和前面这句话效果是一样的
    array2 = Array(1, 2, 3, 4, 5)
    'MsgBox array2(0)
    '-----------------------------------------------------------------------------
    Dim array3() As Variant 'A1:C3必须有值
    array3 = range("A1:C3").Value '注意：用这种方式赋值时，数组是二维数组，即使是这样array3 = Range("A1:A1").Value
    range("E1:G3").Value = array3 '注意：利用这种方式给单元格赋值，array3的属性必须是Vaiant
    '-----------------------------------------------------------------------------
    MsgBox UBound(array3) & "_" & LBound(array3)
    '-----------------------------------------------------------------------------
    Dim txt As String
    txt = Join(array2, "_")
    'MsgBox txt
    '-----------------------------------------------------------------------------
    '将数组中的值批量写入不同的单元格，常用Application方法
    range("H1:H9").Value = Application.WorksheetFunction.Transpose(array2)
End Sub

'比较运算符
Public Sub mysub5()
    'MsgBox Range("A1") Like "a*"
    MsgBox Worksheets("Sheet1").range("A1") Is Worksheets("Sheet1").range("A1") '?这里不是很明白
End Sub

'内置函数
Public Sub mysub6()
    MsgBox "现在时间是：" & Time()
End Sub

'if...else...then
Public Sub mysub7()
    Dim array1() As Variant
    Dim i As Integer
    array1 = Array(1, 2, 3, 4, 5) '利用Array函数创建数组，前面提到过
    
    For i = 0 To 4
        If array1(i) > 3 And array1(i) < 5 Then
            MsgBox "4"
        Else
            MsgBox "<>4" '这里把and替换成&也可以
        End If
    Next
        
End Sub

'稍微复杂一点的if...else...并和for循环结合
Public Sub mysub8()
    Dim num As Integer
    Dim array1 As Variant
    Dim i As Integer
    array1 = Array(1, 2, 3, 4, 5)
    For i = 0 To 4 '开始for循环,注意这里最后还可以加一个[step 步长值]
        num = array1(i)
        If num > 0 Then '开始外层if判断（是否大于0）
            MsgBox "the number is positive number"
            If num = 5 Then '开始内层if判断（具体的数字）
                MsgBox "num=5"
            ElseIf num = 4 Then
                MsgBox "num=4"
            ElseIf num = 3 Then
                MsgBox "num=3"
            ElseIf num = 2 Then
                MsgBox "num=2"
            ElseIf num = 1 Then
                MsgBox "num=1"
            End If
        Else
            MsgBox "the number is nagtive number"
        End If
    Next
End Sub

'select case语句，这里就是类似java中的switch语句
Public Sub mysub9()
    Dim num As Integer
    num = 5
    Select Case num
        Case Is > 0
            MsgBox "the number is positive number"
        Case Is < 0
            MsgBox "the number is nagtive number"
    End Select
End Sub

'do...while语句(循环条件为true，则运行Loop之前的代码)
Public Sub mysub10()
    Dim i As Integer
    i = 1
    Do While i < 5
        MsgBox i
        i = i + 1
    Loop
End Sub

'do...until语句(循环条件为false，则运行Loop之前的代码)
Public Sub mysub11()
    Dim i As Integer
    i = 1
    Do Until i > 5
        MsgBox i
        i = i + 1
    Loop
End Sub

'for each...next(循环次数未知的情况下使用)
Public Sub mysub12()
    Dim sheet1 As Worksheet
    Dim cell1 As range '注意：cell其实是range对象
    Dim i As Integer '用来循环单元格
    Set sheet1 = Worksheets("Sheet1") '注意：给对象变量赋值使用SET，SET 不能省略。
    i = 1
    For Each cell1 In sheet1.range("A1:A" & sheet1.Application.WorksheetFunction.CountA(range("A:A"))) '这里的意思是从A1找到本列最后一个非空单元格，常用Application方法
        Set cell1 = sheet1.Cells(i, "A")
        MsgBox cell1
        i = i + 1
    Next
End Sub

'with语句
Public Sub mysub13()
    Worksheets("Sheet1").Cells(1, "A") = "with测试123"
    With Worksheets("Sheet1").Cells(1, "A").Font
    .Name = "黑体"
    .Bold = True
    .ColorIndex = 5
    End With
End Sub

'参数测试_定义
Public Sub mysub14(ran As range)
    ran = 100
    'MsgBox i & " test"
End Sub


'参数测试2_实现
Public Sub mysub15()

    Dim r As range
    Set r = range("A1:A3")
    Call mysub14(r)  '注意：如果调用有参数的过程必须加call关键词，如果不加则必须去掉后面的括号！
    'MsgBox TypeName(r)
End Sub

'删除非活动的worksheet
Public Sub mysub16()
    Dim sheet As Worksheet
    Application.DisplayAlerts = False '常用Application方法：屏蔽显示警告提醒
    For Each sheet In Worksheets
        If sheet.Name <> ActiveSheet.Name Then
            sheet.Delete
        End If
    Next
End Sub


'对文件的操作
Public Sub mysub17()
    Dim str As String
    str = ThisWorkbook.FullName & "-----" & ThisWorkbook.Path
    MsgBox str
    '下面是文档激活的操作
    Workbooks("aaa.xlsx").Activate '激活aaa.xlax
    MsgBox ActiveWorkbook.Name '& "_____________" & ThisWorkbook.Name
    Workbooks("test.xlsx").Activate '激活test.xlsx
    MsgBox ActiveWorkbook.Name
    '下面是打开关闭的操作
    MsgBox Dir("D:\test.xlsx") '判断文件是否存在，一般同时用Len()函数确定文件名长度
    Workbooks.Add ("D:\test.xlsx") '新建excel文档，如果不加参数就是新建一个空文档
    Workbooks.Open ("D:\test.xlsx") '打开一个excel文档
    ThisWorkbook.Save '保存当前文档，类似的方法还有saveas+路径
    this.workboos.Close '关闭当前文档
    Worksheets.Add '创建新的sheet，和workbook同理，可以添加before或者after标签
    Worksheets("Sheet1").Name = "测试修改名称"
    
End Sub

'文档复制操作，这个经常用所以单列出来
Public Sub mysub18()
    Worksheets("测试修改名称").Copy before:=Worksheets("测试修改名称")
End Sub

'range之——关于Offset和Resize
Public Sub mysub19()
    Cells(1, 1).Offset(2, 5) = "offset test" '为下2右5单元格复制
    range("A2").Resize(1, 4).Select '重新选择range范围
End Sub

'range之——UsedRange
Public Sub mysub20()
    Dim sht As Worksheet
    Set sht = Application.Workbooks("aaa.xlsx").Worksheets("test")
    sht.UsedRange.Select '选择sheet中所有已用单元格
    range("D2").End(xlDown).Select '选择D列最后一个已用单元格
    MsgBox sht.range("D1").End(xlDown).Row '得到range范围列的已用行数
    range("A1").Clear '清除
End Sub

'range之——cut
Public Sub mysub21()
    range("A1:B2").Cut Destination:=range("D3:E4") ' 指定复制粘贴位置
End Sub

'遍历文件夹中的所有excel文件
Public Sub mysub22()
    Dim filename As String
    filename = Dir("D:\*.xlsx")
    Do While filename <> ""
        MsgBox filename
        filename = Dir
    Loop
End Sub



'下面开始是函数function相关，其实和sub是类似的，只是多了返回值
'第一个function,显示当前时间
Public Function myfun1()
    myfun1 = Time() '这里其实就是函数的返回值
End Function

'统计单元格中红色个数的函数
Public Function myfun2(user_range As range) '这里的参数是用户选择
    Application.Volatile True '注意：标记函数为易失性函数，常用Application方法
    Dim range As range
    For Each range In user_range
        If range.Interior.ColorIndex = 3 Then
        myfun2 = myfun2 + 1
        End If
    Next range
End Function