VBA遍历当前目录下指定类型的excel文件并复制文件内指定的内容到新表中

最近在做水质分析数据录入的时候，需要根据监测井编号到多个excel表中查询该编号对应的井的水质分析数据，并将单口井的水质分析数据复制到新表中。由于检测中心给的

水质分析数据很多，而且还分布在不同的工作薄中，一个个得查询再复制不仅工作量巨大、而且容易出错。因此编写了以下代码，让这部分工作实现自动化。

这部分内容涉及的知识点有：多工作薄交叉复制、获取某一目录下所有excel工作薄、获取某一目录下所有指定类型excel工作薄、创建工作薄、打开工作薄并操作

现在把代码整理贴出来，方便以后参考调用。

Option Explicit

Sub test()

    Dim dict, i, v

    Set dict = CreateObject("Scripting.Dictionary") '创建dictionary

    i = 1

    Do While Cells(i, 1) <> "" '遍历当前excel文件第一列内容，直到第一列单元格值为空

        dict.Add i, Cells(i, 1).Text '将第一列单元格的值添加到dict中

        i = i + 1

    Loop

    Create_New_Workbook

    v = dict.Items

    For i = 0 To dict.Count - 1

        HuiZong (v(i))

    Next i

End Sub

Function HuiZong(WellId As String)

    Dim myfile, mypath, wb               '声明变量

    Application.ScreenUpdating = False   '关闭屏幕更新

    mypath = ThisWorkbook.Path           '找到当前工作簿的路径

    myfile = Dir(mypath & "\*.xls*")     '遍历当前文件夹下的Excel文件

    Do While myfile <> ""                '当找到的文件不为空时

        If myfile Like "W*" Then         '当找到的文件为指定类型的excel工作薄时

            Set wb = GetObject(mypath & "\" & myfile)   '得到dir找到的工作簿的内容，设为wb

            With wb.Worksheets("报告数据")              '对找到的工作簿的“报告数据”进行操作

                Dim j As Integer

                j = 1

                Do While True

                    If .Cells(j, 4) = "" And .Cells(j + 1, 4) = "" Then

                        Exit Do

                    End If

                    If .Cells(j, 4) = WellId Then '找到指定内容，进行后续操作

                       Dim aa '复制到新的工作薄内,恢复屏幕更新并退出函数

                       aa = My_Copy(j, myfile, WellId)

                       Application.ScreenUpdating = True

                       Exit Function

                    End If

                    j = j + 1

                Loop

            End With

            wb.Close False      '关闭wb工作簿且不保存

        End If

        myfile = Dir          '寻找下一个Excel工作簿

    Loop

    MsgBox (WellId + "的数据未找到！")

    Application.ScreenUpdating = True   '恢复屏幕更新

End Function

Function My_Copy(j As Integer, f As Variant, t As Variant)

    '将f工作薄中r(j)—>r(j+35)行的数据复制到t工作薄内

    Dim mypath, myfile, wb, wb1, i, k, p

    mypath = ThisWorkbook.Path

    myfile = mypath & "\" & f

    Set wb = GetObject(myfile)

    Set wb1 =
97f1
GetObject(mypath & "\" & t & ".xls")

    For i = 1 To 8

         p = j - 1

         For k = 1 To 35

            wb1.Worksheets(1).Cells(k, i) = wb.Worksheets("报告数据").Cells(p, i)

            p = p + 1

        Next k

    Next i

    wb1.Save

    wb1.Close

End Function

Function Create_New_Workbook() '新建工作薄

    Application.ScreenUpdating = False

    Dim gzb As Workbook

    Dim mypath, i, wb

    mypath = ThisWorkbook.Path '获取当前工作薄所在的路径

    Set wb = GetObject(mypath & "\" & "date.xls") '设置wb为当前目录下的date.xls工作薄

    i = 1

    Do While Cells(i, 1) <> ""

         Set gzb = Workbooks.Add

          gzb.SaveAs mypath & "\" & wb.Worksheets(1).Cells(i, 1).Text & ".xls" '保存工作薄的名字为Cells(i,1)中的字符

          gzb.Close

          i = i + 1

    Loop

    Application.ScreenUpdating = True

End Function