VBA应用实战案例（1）

VBA在实际工作中应用时，为了满足工作特定的需求会需要一定复杂程度的代码，这个过程会涉及比较复杂的设计思路和比较多VBA语法的应用，会产生较多行数的代码，此时，一方面需要保证代码可以正常运行，另一方面需要考虑代码整体的运行速度。前者是基本要求，而后者则是更高层次的要求，毕竟写VBA代码就是提高我们的工作效率的，很少有人愿意等运行结果等个几十分钟甚至一两个小时。

Case:本实例已知一个产品ID,需要在文件夹中找到组成结构LA,LB及LC的ID命名的表格的特定数据，将它们复制到指定位置。该过程需要经历以下几步：

1.利用这个ID在指定路径的表格中找到组成结构的三部分LA,LB/LC的ID；

2.利用找到的LA,LB/LC ID，找到以ID命名所在的文件夹位置；因为三个ID命名的文件夹下的次级文件夹名称不相同，不能指定固定文件夹路径,需要先找到各自文件夹的路径

3.找到LA,LB及LC ID所在的文件夹位置后，遍历该位置下的文件夹，找到目标文件夹，然后再遍历文件夹下的文件夹和表格文件找到目标表格；

4.筛选三个表格中的特定数据，然后分别复制到指定工作簿的单元格中。

上述任务可以拆分成多步，按照流程图逐步去实现。根据上述拆分，实现目的需要做到VBA打开文件夹、文件和工作簿，VBA使用Vlookup函数及Autofilter方法，VBA中数组的运用，VBA遍历文件夹及次级文件夹所有文件，VBA复制粘贴数据及关闭工作簿。

具体实现方法看示例。

Sub AOI_Defect()
    Application.ScreenUpdating = False    '禁止屏幕更新，运行时屏幕不闪烁
    Application.Calculation = xlCalculationManual   '禁止excel工作表自动计算，加快运行速度
    
    Bookfile = ThisWorkbook.Name
     
  '目的1：这段代码是打开指定文件夹表格，利用已知ID用Vlookup查询组成部分LA,LB的ID
    Dim AOI_Data as string,lotname as string,LA_ID As String, LB_ID As String
        ChDrive "Y"   '打开驱动盘
        FilePath = "Y:\文件放置处\"
        ChDir FilePath   '打开驱动文件
        
        AOI_Data = "数据记录表.xlsx"
        
        lotname = shStart.Cells(10, 3)
        
        Workbooks.Open FileName:=FilePath & AOI_Data, UpdateLinks:=False, ReadOnly:=True   '以只读方式打开工作簿
        Workbooks(AOI_Data).Sheets("Opal ").Activate
        
        LA_ID = Application.VLookup(lotname, Range("C:E"), 2, 0)   'Vlookup函数应用
        LB_ID = Application.VLookup(lotname, Range("C:E"), 3, 0)
        
        Workbooks(AOI_Data).Close False
        
'目的2：这部分代码使用Dir方法遍历文件夹，找到目标的三个文件夹       
		Dim AOIPath as string，ListPath as string
		Dim LAPath as string,LBPath as string,LCPath as string
		Dim LAFile as string,LBFile as string,LCFile as string
        AOIPath = "Z:\Datasource\AOI_Map\VZC001\Str\"
        ListPath = Dir(AOIPath, vbDirectory)   '遍历目标文件夹下的文件夹
        Do
        If Right(ListPath, 11) = LA_ID Then
            LAPath = ListPath
        ElseIf Right(ListPath, 11) = LB_ID Then
            If Left(Right(ListPath, 19), 4) = "LBCA" Then
                LBPath = ListPath
            ElseIf Left(Right(ListPath, 19), 4) = "LCCA" Then
                LCPath = ListPath
            End If
        End If
        ListPath = Dir
        Loop Until ListPath = ""
        
        LAFile = AOIPath & LAPath & "\"
        LBFile = AOIPath & LBPath & "\"    '定义LA,LB及LC的路径
        LCFile = AOIPath & LCPath & "\"


'目的3：这部分代码使用数组结合Dir方法遍历文件夹，找到目标文件夹中的文件
        Dim oFso As Object
        Set oFso = CreateObject("Scripting.FileSystemObject")   '定义文件夹对象
        Dim oFolder As Object
        Dim oFile As Object
        Dim ArrFile，sPath as string
        Dim Target_File as string
 
        ArrFile = Array(LAFile, LBFile, LCFile)   '数组定义路径变量
        For Each sPath In ArrFile				  '循环遍历每个路径
            Set oFolder = oFso.GetFolder(sPath)   
            If oFolder.subfolders.Count > 0 Then     '判断指定的文件夹是否含有文件
                For Each oFile In oFolder.subfolders
                        Target_File = Dir(oFile & "\" & "*.csv", vbDirectory)   '遍历文件夹下的文件夹和csv文件
                        Do
                            If Right(Target_File, 9) = "CLS01.csv" Then
                                Workbooks.Open FileName:=oFile & "\" & Target_File, UpdateLinks:=False, ReadOnly:=True
                            End If
                        Target_File = Dir
                        Loop Until Target_File = ""
                Next
            End If
        Next
        
        ThisWorkbook.Sheets("Lens AOI").Range("H4:V9603").ClearContents

'目的4：这部分代码是筛选三个sheet非“Good”字段，并将筛选结果复制到指定路径的工作簿的单元格      
        With Workbooks(LAPath & "_CLS01.csv").Sheets(1)
        .Range("F9607", .[F9607].End(xlDown)).AutoFilter field:=1, Criteria1:="<>Good"    'Autofilter反向筛选非good得字段
        .Range("A9607", .[B9607].End(xlDown)).Copy Destination:=ThisWorkbook.Sheets("Lens AOI").Range("H3")   '复制粘贴(一行代码)
        .Range("F9607", .[F9607].End(xlDown)).Copy Destination:=ThisWorkbook.Sheets("Lens AOI").Range("J3")
        End With
        Workbooks(LAPath & "_CLS01.csv").Close False
        
        With Workbooks(LCPath & "_CLS01.csv").Sheets(1)
        .Range("F9543", .[F9543].End(xlDown)).AutoFilter field:=1, Criteria1:="<>Good"
        .Range("A9543", .[B9543].End(xlDown)).Copy Destination:=ThisWorkbook.Sheets("Lens AOI").Range("M3")
        .Range("F9543", .[F9543].End(xlDown)).Copy Destination:=ThisWorkbook.Sheets("Lens AOI").Range("O3")
        End With
        Workbooks(LCPath & "_CLS01.csv").Close False
        
        With Workbooks(LBPath & "_CLS01.csv").Sheets(1)
        .Range("F9543", .[F9543].End(xlDown)).AutoFilter field:=1, Criteria1:="<>Good"
        .Range("A9543", .[B9543].End(xlDown)).Copy Destination:=ThisWorkbook.Sheets("Lens AOI").Range("R3")
        .Range("F9543", .[F9543].End(xlDown)).Copy Destination:=ThisWorkbook.Sheets("Lens AOI").Range("T3")
        End With
        Workbooks(LBPath & "_CLS01.csv").Close False
        
        Application.Calculation = xlCalculationAutomatic   '禁止自动计算，先关闭结束开启
        Application.ScreenUpdating = True   '禁止屏幕闪烁，先关闭结束开启
        
End Sub

上述代码是工作中遇到的实例中的一部分代码的解析，可见实现自动化的目的需要较多的VBA语法综合应用，熟悉多种语法，才能更灵活的应用在实例中。

实际上，细心一点就会发现，上述代码开始禁用了屏幕刷新和excel表格自动计算，中间的代码运用数组，这些方法都是可以提升代码运行速度的，这也是VBA代码较多时需要考虑的事情，也是进阶学习中需要去考虑的。