ExcelVBA_003 多工作簿提取信息

本文转载自公众号:ExcelVBA编程办公自动化实例教程，作者:TextSeven

一、需求说明

        举办活动回收了很多个人报名表，每个报名表为一个独立（文件）工作簿，现在需要汇总为信息一览表。

个人报名表  格式如下图：

信息一览表  格式如下图：

二、实现思路

    （1）用dir与 Do While……Loop循环语句配合循环指定文件夹下的张三、李四、王五等个人报名表。

    （2）将【个人信息表】的内容提取到【信息一览表】的每一行上。

三、实现代码

    

四、实现效果

五、佛系打赏哦

 

六、福利

'凑字数附上代码

Public Sub GatherData()

    Dim Wb As Workbook, Sht As Worksheet

    Dim OpenWb As Workbook, OpenSht As Worksheet

    Const SHEET_INDEX = 1, HEAD_ROW = 1

    Dim FolderPath, FileName, RowIndex

    Set Wb = Application.ThisWorkbook

    Set Sht = Wb.Worksheets('汇总表')

    Sht.UsedRange.Offset(HEAD_ROW).ClearContents '保留标题行清除其他内容

     FolderPath = Wb.Path & '\文件夹\'  '设置报名表所在文件夹的路径

    RowIndex = 1

    FileName = Dir(FolderPath & '*.xls*')

    Do While FileName <> ''

        Debug.Print FileName

        If FileName <> ThisWorkbook.Name Then '排除与一览表重名的工作簿 避免打开错误

            RowIndex = RowIndex 1 '下移一行输出

            Set OpenWb = Application.Workbooks.Open(FolderPath & FileName) '打开工作簿

            With OpenWb

                Set OpenSht = OpenWb.Worksheets(SHEET_INDEX) '指定工作表

                With OpenSht

                    '将个人报名表的内容对应到一览总表

                    Sht.Cells(RowIndex, 1).Value = .Range('B3').Value

                    Sht.Cells(RowIndex, 2).Value = .Range('D3').Value

                    Sht.Cells(RowIndex, 3).Value = .Range('F3').Value

                    Sht.Cells(RowIndex, 4).Value = .Range('B4').Value

                    Sht.Cells(RowIndex, 5).Value = .Range('D4').Value

                    Sht.Cells(RowIndex, 6).Value = .Range('B5').Value

                    Sht.Cells(RowIndex, 7).Value = ''' & .Range('D5').Value

                    Sht.Cells(RowIndex, 8).Value = .Range('F5').Value

                    Sht.Cells(RowIndex, 9).Value = .Range('B6').Value

                    Sht.Cells(RowIndex, 10).Value = ''' & .Range('B7').Value

                    Sht.Cells(RowIndex, 11).Value = FileName

                End With

                .Close False

            End With

        End If

        FileName = Dir

    Loop

    '释放对象

    Set Wb = Nothing: Set Sht = Nothing

    Set OpenWb = Nothing: Set OpenSht = Nothing

End Sub