最近在做水质分析数据录入的时候，需要根据监测井编号到多个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
