【VBA、Excel】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 = 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