VBA基础

Sub 语法错误的调试()
    '代码无法运行，根据弹出的提示调试

    '1-变量未定义
    'Dim my_i As Long
    my_i = 10000
    Debug.Print "指定的数是" & my_i

    '2-对象变量缺少关键字set
    Dim sht As Worksheet
    Set sht = ThisWorkbook.Sheets(1) 'set
    Debug.Print sht.Name

    '3-循环或判断语句不完整，缺失结束语句
    If my_i > 0 Then
        Debug.Print "正确"
    'End If '缺失

    For Each sht In ThisWorkbook.Sheets
        Debug.Print sht.Name
    'Next '缺失

    '4-计算错误
    Dim a As Integer, b As Integer
    a = 5
    b = 1
    'Debug.Print a / (a - b * a) '除数为0

End Sub

Sub 运行和逻辑检查()
    '代码中断、崩溃、逻辑错误时，通过设置断点、单步执行
    '观察本地窗口的变量变化是否符合预期
    '立即窗口打印调试的信息，可在调试时执行命令
    '监视窗口添加表达式，监视变量的变化，

    '某个时间段的汽车销量存储在表格中，计算燃油车各车型大类的销量和个数
    Dim aData, acx, s
    Dim i As Long, jc_i As Long, suv_i As Long, mpv_i As Long, cp_i As Long
    Dim jc_Tol As Long, suv_Tol As Long, mpv_Tol As Long, cp_Tol As Long

    aData = ThisWorkbook.Sheets("示例").Range("A1").CurrentRegion

    '立即窗口查看需要循环的总行数
    jc_i = 0: suv_i = 0                         '各车型个数从0开始计数
    mpv_i = 0: cp_i = 0
    '循环前设置断点，
    For i = 1 To UBound(aData)                  '循环数据源的每一行
        If aData(i, 4) = "燃油" Then            '判断能源类型是否是燃油
            Select Case aData(i, 3)             'select case条件判断车系分类
                Case Is = "轿车"                '对该车系计数 和 累加销量
                    jc_i = jc_i + 1
                    jc_Tol = jc_Tol + aData(i, 5)
                Case Is = "SUV"
                    suv_i = suv_i + 1
                    suv_Tol = suv_Tol + aData(i, 5)
                Case Is = "MPV"
                    mpv_i = mpv_i + 1
                    mpv_Tol = mpv_Tol + aData(i, 5)
                Case Is = "跑车"
                    cp_i = cp_i + 1
                    cp_Tol = cp_Tol + aData(i, 5)
            End Select

        End If
    Next i

    Debug.Print "轿车是个数是：" & jc_i & vbCrLf & "销量是： " & jc_Tol  '立即创建输出 车系计数和总销量
    Debug.Print "SUV是个数是：" & suv_i & vbCrLf & "销量是： " & suv_Tol
    Debug.Print "MPV是个数是：" & mpv_i & vbCrLf & "销量是： " & mpv_Tol

End Sub

Sub 减少与Excel的交互()
    Dim startTime_1 As Double, startTime_2 As Double

    '每次循环都访问单元格，看写入10000个数据的耗时
    startTime_1 = Timer '获取开始时间
    Dim i As Long
    For i = 1 To 10000
        ThisWorkbook.Sheets("示例-代码优化").Cells(i, 1).Value = i
    Next i
    Debug.Print "执行时间: " & Format(Timer - startTime_1, "0.000") & " 秒"

   '内存中循环，一次写入，即和Excel只交互一次，看写入10000个数据的耗时
    startTime_2 = Timer '获取下个代码段的开始时间
    Dim aData(1 To 10000, 1 To 1) As Long '声明一个数组
    For i = 1 To 10000
        aData(i, 1) = i '内存操作
    Next i
    ThisWorkbook.Sheets("示例-代码优化").Range("B1:B10000").Value = aData  '一次写入
    Debug.Print "执行时间: " & Format(Timer - startTime_2, "0.000") & " 秒"

End Sub

Sub 控制excel的非必要功能()
    '批量操作工作簿，打开后取值，看关闭屏幕刷新与否的耗时对比
    '用之前合并工作簿表的示例代码，清除掉合并部分，只保留打开和关闭的操作

    Dim FileToOpen As Variant
    Dim i As Long
    Dim startTime_1 As Double, startTime_2 As Double

    '1-不禁用屏幕刷新功能
    FileToOpen = Application.GetOpenFilename("Excel文件,*.xl*", , "请选择要合并的多个工作簿/表", , True)
    startTime_1 = Timer '获取开始时间，从选择工作簿开始后、核心代码行运行前开始计时
    For i = 1 To UBound(FileToOpen)
        Workbooks.Open Filename:=FileToOpen(i)
        ActiveWorkbook.Close  '最后关闭工作簿
    Next i
    Debug.Print "选择" & UBound(FileToOpen) & "个文件打开并关闭的执行时间:" & Format(Timer - startTime_1, "0.000") & " 秒"

    '2-禁用屏幕刷新功能
    Application.ScreenUpdating = False  ' 关闭屏幕刷新
    FileToOpen = Application.GetOpenFilename("Excel文件,*.xl*", , "请选择要合并的多个工作簿/表", , True)
    startTime_2 = Timer '获取下个代码段的开始时间
    For i = 1 To UBound(FileToOpen)
        Workbooks.Open Filename:=FileToOpen(i)
        ActiveWorkbook.Close  '最后关闭工作簿
    Next i
    Debug.Print "选择" & UBound(FileToOpen) & "个文件打开并关闭的执行时间: " & Format(Timer - startTime_2, "0.000") & " 秒"
    Application.ScreenUpdating = True  ' 注意在主程序运行结束后恢复原状

    '其他的几个控制功能
    Application.Calculation = xlCalculationManual   ' 手动计算
    Application.Calculation = xlCalculationAutomatic         '恢复自动计算

    Application.DisplayAlerts = False              '禁止警告，禁止掉新增工作表、重命名、关闭未保存的工作簿等等弹出的提醒，根据需要谨慎使用
    Application.DisplayAlerts = True               '恢复初始设置

    Application.EnableEvents = False    ' 禁用事件
    Application.EnableEvents = True    '恢复初始设置
End Sub

Sub with高效引用对象()
    '对一个单元格赋值，并设置单元格格式，边框、底色、字体颜色等等，最后清除，循环100次看看
    Dim startTime_1 As Double, startTime_2 As Double
    Dim i As Integer

    '常规引用
    startTime_1 = Timer '获取开始时间
    For i = 1 To 100
        ThisWorkbook.Sheets("示例-代码优化").Range("C1").Value = "C1"
        ThisWorkbook.Sheets("示例-代码优化").Range("C1").Font.Bold = True
        ThisWorkbook.Sheets("示例-代码优化").Range("C1").Font.Color = -16776961
        ThisWorkbook.Sheets("示例-代码优化").Range("C1").Interior.Color = vbYellow
        ThisWorkbook.Sheets("示例-代码优化").Range("C1").Clear
    Next i
    Debug.Print "执行时间: " & Format(Timer - startTime_1, "0.000") & " 秒"

    '使用with高效引用变量
    startTime_2 = Timer '获取下个代码段的开始时间
    For i = 1 To 100
        With ThisWorkbook.Sheets("示例-代码优化").Range("C1")
            .Value = "C1"
            .Font.Bold = True
            .Font.Color = -16776961
            .Interior.Color = vbYellow
            .Clear
        End With '结束语
    Next i
    Debug.Print "执行时间: " & Format(Timer - startTime_2, "0.000") & " 秒"
End Sub

Sub 关于循环的优化()
    '1-选择高效的循环，避免在循环中访问对象属性，
    '比如第一个示例"减少和Excel的互动",低效的是在循环中访问对象，高效的是读取到数组后，一次性写回！

    '能循环一次尽量不多次。
    Dim i As Long, Tol_1 As Long, Tol_2 As Long
    For i = 1 To 100
        Tol_1 = Tol_1 + i
        Tol_2 = Tol_2 + i * i
    Next i
    Debug.Print Tol_1 / Tol_2
    '永远好过
    For i = 1 To 100
        Tol_1 = Tol_1 + i
    Next i
    For i = 1 To 100
        Tol_2 = Tol_2 + i * i
    Next i
    Debug.Print Tol_1 / Tol_2

    '使用For Each代替索引处理对象集合，永远会更快
    Dim sht As Worksheet
    For Each sht In ThisWorkbook.Sheets
        sht.Activate
    Next sht
    '永远快过
    For i = 1 To ThisWorkbook.Sheets.Count
        ThisWorkbook.Sheets(i).Activate
    Next i

    '尝试通过数学方法减少循环层数
    For i = 1 To 10
        Tol_1 = Tol_1 + Cells(i, 1)
    Next i
    '远不如，直接用工作表函数
    Tol_1 = Sum(Range("A1:A10"))

End Sub

Sub 利用字典对象快速查找()

    Dim dict As Object                              '声明一个对象dict
    Set dict = CreateObject("Scripting.Dictionary") '初始化对象为字典

    Dim aData
    Dim i As Long
    aData = ThisWorkbook.Sheets("示例-代码调试").Range("A1").CurrentRegion '把工作表A1单元格的当前区域，赋值给aData，减少和Excel的交互

    '循环对象
    For i = 1 To UBound(aData)
        dict(aData(i, 1)) = dict(aData(i, 1)) + aData(i, 5) '例如字典的“键”不重复的特征，对每个相同的键对应的值累加求和
    Next i

    If dict.exists("东风日产") Then
        Debug.Print "销量合计: " & dict("东风日产")  '用“键”名称，快速查找对应的值
    End If
End Sub

Sub 集合处理唯一值()
    '利用集合的特点，获取不存放重复的元素
    '比循环遍历所有元素，判断单个元素是否在目标区域或数组内出现，依次求得唯一值更快

    Dim uItems As Collection    '新建一个集合对象uItems
    Set uItems = New Collection '初始化为一个新的集合实例

    Dim aData
    Dim i As Long
    aData = ThisWorkbook.Sheets("示例-代码调试").Range("A1").CurrentRegion '把工作表A1单元格的当前区域，赋值给aData，减少和Excel的交互，已能提交效率

    On Error Resume Next '忽略重复错误，往集合中添加元素时，如果已存在，会弹出错误并终止运行，我们的目标是为了获取不重复值，就利用错误处理忽略这类错误
    For i = 1 To UBound(aData)
        uItems.Add aData(i, 1), aData(i, 1)
    Next i
    On Error GoTo 0

    '以上就得到了一个不含重复值的集合
    Dim item As Variant
    For Each item In uItems '遍历集合的每个元素，在立即创建打印出来
        Debug.Print item
    Next item

    '当然也可以逐个写入到工作簿的工作表中，with高效引用对象
    With ThisWorkbook.Sheets("示例-代码调试")
        For i = 1 To uItems.Count
            .Cells(i, 8) = uItems(i)
        Next i
    End With

    '最好是一次写入到工作簿的工作表中，减少和excel的交互
    Dim arr() As Variant
    ReDim arr(1 To uItems.Count)
    For i = 1 To uItems.Count
        arr(i) = uItems(i)
    Next i
    ThisWorkbook.Sheets("示例-代码调试").Range("I1:I" & UBound(arr)).Value = Application.Transpose(arr) '一次写入，这个的arr是一维的(横向)，写入到列区域中，用Transpose转换(纵向)
End Sub