VBA汇总特定路径下数据到Excel

汇总工作表数据是VBA在Excel常见的应用，很多人在学习初期应该就了解如何实现。但是这次的案例与在同一个工作簿不同工作表间汇总数据不同，一方面两个原始数据的工作簿不在固定路径下，另一方面原始数据的父文件夹下的工作簿非常多。

Case：打开在不固定路径下的原始数据A工作簿（具有固定命名格式），将原始数据汇总到到当前工作簿的新工作表Raw data中，打开已知路径下多个相似命名工作簿中的特定工作簿，并将原始数据汇总到当前工作簿的新工作表Final中。

基于以上的客观条件，就需要：1.需要人为去选择文件路径，则需要用到GetOpenFilename方法，还需要判断文件命名格式；2.需要判断多个相似命名的文件夹，则需要用到循环或者遍历的方法逐一判断目标文件夹下的多个工作簿并打开指定工作簿，在完成上述两个核心操作后，汇总数据就显得比较容易了。

具体代码实现方法如下：

Sub Data()

    Application.ScreenUpdating = False   '禁止屏幕刷新
    Application.Calculation = xlCalculationManual   '将excel表格计算方式改为手动，避免公式自动计算拖慢代码运行速度
    
    Dim BookName as String,shRaw as Workbook,shMD as Workbook,shStart as Workbook   '定义变量类型
    BookName = ThisWorkbook.Name
    Set shRaw = Workbooks(BookName).Sheets("Raw")
    Set shMD = Workbooks(BookName).Sheets("Final")
    Set shStart = Workbooks(BookName).Sheets("Start")


        FilePath = "D:\Transfer\Raw Data\Raw\"
        ChDrive "D"
        ChDir FilePath   '改变目标路径或者文件夹
        Dim Openfile as Object   '定义变量类型
        Dim fso As Object, sFile As Object, blnExist As Boolean
        Dim FileName As String, LineText As Variant
        Dim Checkname as String,Maxname as String,Rawfilename as String
        Dim ftpPath as String,MyName as String

        Const ForReading = 1
        Set fso = CreateObject("Scripting.FileSystemObject")    '创建FileSystemObject对象

        Openfile = Application.GetOpenFile("raw files (*.csv), *.csv")
        blnExist = fso.FileExists(Openfile)        '判断文件是否存在，如果不存在，则退出过程
        If Not blnExist Then MsgBox "Please Open .csv File ！": Exit Sub
'
        Checkname = Split(Openfile, "\")   '利用Split函数拆分字符串
        Maxname = UBound(Checkname)
        Rawfilename = Checkname(Maxname)
        shStart.Cells(10, 3) = Checkname(4)
            
        If UCase(Left(Rawfilename, 3)) <> "PRE" Then   '拆分字符串判断文件夹格式，不符合条件则退出子程序
            MsgBox "Wrong file! Please open Pre_xxxxxx.csv"
            Exit Sub
        End If
'
        shRaw.Cells.ClearContents   '清除工作表所有内容
        Workbooks.Open FileName:=Rawfilename, UpdateLinks:=False, ReadOnly:=False   '打开手动选择的工作表
        Workbooks(Rawfilename).Sheets(1).Cells.Copy Destination:=shRaw.Range("A1")   '将工作表内容复制到目标工作表
        Application.CutCopyMode = False    '取消剪切板粘贴模式
        Workbooks(Rawfilename).Close False   '关闭工作簿并不保存


		Dim shOpenSummary as Worksheet,iSummary as integer,iEnd as integer   '定义变量类型
        ftpPath = "D:\Transfer\Raw Data\LK Data\" & shStart.Cells(3, 3) & "\"
        MyName = Dir(ftpPath, vbDirectory)    '遍历目标路径

        Do While MyName <> ""   
            If Right(MyName, 9) = "Final.csv" Then   ''判断遍历的文件名称
                Openfile = MyName
            End If
            MyName = Dir()   ' 再次将变量赋值给Dir，进行遍历
        Loop
        
        Workbooks.Open FileName:=Openfile, UpdateLinks:=False, ReadOnly:=True   '只读模式打开遍历到的非空工作表
        sumFile = Split(Openfile, "\")(UBound(Split(Openfile, "\")))
        Set shOpenSummary = Workbooks(sumFile).Sheets(1)    '设定新工作表名称
        iSummary = 3
        iEnd = shOpenSummary.Range("A100000").End(xlUp).Row    '计算A列行数
        shMD.Range("A1:DJ" & iEnd - 2).Value = shOpenSummary.Range("A3:DJ" & iEnd).Value    '将工作表内容复制到目标工作表
        Workbooks(sumFile).Close False   ''关闭工作簿并不保存
        
        shStart.Activate
        MsgBox " Done! "
        Application.Calculation = xlCalculationAutomatic   '自动计算模式开启，与开始手动模式成对存在
        Application.ScreenUpdating = True   '关闭禁止屏幕刷新
     
End Sub

本段代码是读取两个文件的数据，并将数据复制到指定位置，一种方法是打开指定的文件夹判断正确的文件名称后打开进行操作，另一个则是通过遍历结合判断的方法找到正确的文件后进行操作。其中，打开文件名的判断及打开后的错误预防值得参考，后续需要设计复杂的程序时可以借鉴。