【VBA】海量文件也不怕，一键搞定数据查找和汇总~

昨天的文章不就是有点儿简单嘛，没想到花花掉粉，说好的真爱不渝呢~~

那今天就来点儿实在的~~

领导发来一个文件夹，内有成绩单文件，每个文件又有若干工作表~~要从中找到我们学校的成绩并汇总，以待进一步分析~~

小梁

假装有这么多成绩单~~

小梁

假装有这么多学校、这么多工作表~~

【好消息】每一年的科目、格式都相同，只是学校排序略有不同；

【坏消息】文件个数n>=20，每个文件的工作表个数n>=3；

肿么办？

先来看看demo：

若是拷贝这个文件到成绩单文件夹，那连选路径都省了，直接导入就可以啦——能点一下鼠标就坚决不点两下，哈哈~~

小梁

咳咳，这里只是实现了基本功能，程序的健壮性和效率有待进一步完善！仅作参考~~：）

代码如下：

Sub 导入数据()

Dim wb As Workbook, sht As Worksheet

Dim fn, fp As String

Dim i_row, i_col As Integer

Dim i As Integer

Dim school As String

school = ThisWorkbook.Sheets(1).Cells(1, 'B')

'清空数据

'ThisWorkbook.Sheets(1).Range('A3:G1048576').ClearContents

'找到空行行号

i_row = Range('E1048576').End(xlUp).Row 1

'i_row = 3

'Application.ScreenUpdating = False

'当前路径

If str_filepath = '' Then str_filepath = ThisWorkbook.Path

fn = Dir(str_filepath & '\*.xlsx')

Do While fn <> ''

    

    '本文件除外

    If fn <> ThisWorkbook.Name Then

        

        '合成路径

        fp = str_filepath & '\' & fn

        

        '取得工作簿workbook

        Set wb = GetObject(fp)

        

        '对每一个工作表

        For Each sht In wb.Worksheets

        

            '找到指定学校所在行

           i = WorksheetFunction.Match(school, sht.Range('A1:A1000'), 0)

            

            '拷贝两行数据

            sht.Range(sht.Cells(i, 'A'), sht.Cells(i 1, 'D')).Copy

            ThisWorkbook.Sheets(1).Cells(i_row, 'A').PasteSpecial Paste:=xlPasteValues

            

            '保存路径和工作表名称

            ThisWorkbook.Sheets(1).Cells(i_row, 'E') = str_filepath

            ThisWorkbook.Sheets(1).Cells(i_row, 'F') = wb.Name

            ThisWorkbook.Sheets(1).Cells(i_row, 'G') = sht.Name

            

            ThisWorkbook.Sheets(1).Cells(i_row 1, 'E') = str_filepath

            ThisWorkbook.Sheets(1).Cells(i_row 1, 'F') = wb.Name

            ThisWorkbook.Sheets(1).Cells(i_row 1, 'G') = sht.Name

            

            i_row = i_row 2

        Next

        

        wb.Close False

    

    End If

    fn = Dir

Loop

'Application.ScreenUpdating = True

End Sub

Sub 指定文件夹()

With Application.FileDialog(msoFileDialogFolderPicker)

    

    If .Show = False Then Exit Sub

    str_filepath = .SelectedItems(1)

End With

    

End Sub

这样看代码眼睛都花了，有类似需求的朋友，还是快来索取源文件吧~~：）

【互动时刻】

你最想了解Excel的哪些方面呢？

留言说一说，下一期可能就是写给你的主题哟~~：）