最近在做水質(zhì)分析數(shù)據(jù)錄入的時(shí)候，需要根據(jù)監(jiān)測(cè)井編號(hào)到多個(gè)excel表中查詢(xún)?cè)摼幪?hào)對(duì)應(yīng)的井的水質(zhì)分析數(shù)據(jù)，并將單口井的水質(zhì)分析數(shù)據(jù)復(fù)制到新表中。由于檢測(cè)中心給的
水質(zhì)分析數(shù)據(jù)很多，而且還分布在不同的工作薄中，一個(gè)個(gè)得查詢(xún)?cè)購(gòu)?fù)制不僅工作量巨大、而且容易出錯(cuò)。因此編寫(xiě)了以下代碼，讓這部分工作實(shí)現(xiàn)自動(dòng)化。
這部分內(nèi)容涉及的知識(shí)點(diǎn)有：多工作薄交叉復(fù)制、獲取某一目錄下所有excel工作薄、獲取某一目錄下所有指定類(lèi)型excel工作薄、創(chuàng)建工作薄、打開(kāi)工作薄并操作
現(xiàn)在把代碼整理貼出來(lái)，方便以后參考調(diào)用。
Option Explicit
Sub test()
Dim dict, i, v
Set dict = CreateObject("Scripting.Dictionary") '創(chuàng)建dictionary
i = 1
Do While Cells(i, 1) <> "" '遍歷當(dāng)前excel文件第一列內(nèi)容，直到第一列單元格值為空
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 '關(guān)閉屏幕更新
mypath = ThisWorkbook.Path '找到當(dāng)前工作簿的路徑
myfile = Dir(mypath & "\*.xls*") '遍歷當(dāng)前文件夾下的Excel文件
Do While myfile <> "" '當(dāng)找到的文件不為空時(shí)
If myfile Like "W*" Then '當(dāng)找到的文件為指定類(lèi)型的excel工作薄時(shí)
Set wb = GetObject(mypath & "\" & myfile) '得到dir找到的工作簿的內(nèi)容，設(shè)為wb
With wb.Worksheets("報(bào)告數(shù)據(jù)") '對(duì)找到的工作簿的“報(bào)告數(shù)據(jù)”進(jìn)行操作
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 '找到指定內(nèi)容，進(jìn)行后續(xù)操作
Dim aa '復(fù)制到新的工作薄內(nèi),恢復(fù)屏幕更新并退出函數(shù)
aa = My_Copy(j, myfile, WellId)
Application.ScreenUpdating = True
Exit Function
End If
j = j + 1
Loop
End With
wb.Close False '關(guān)閉wb工作簿且不保存
End If
myfile = Dir '尋找下一個(gè)Excel工作簿
Loop
MsgBox (WellId + "的數(shù)據(jù)未找到！")
Application.ScreenUpdating = True '恢復(fù)屏幕更新
End Function
Function My_Copy(j As Integer, f As Variant, t As Variant)
'將f工作薄中r(j)—>r(j+35)行的數(shù)據(jù)復(fù)制到t工作薄內(nèi)
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("報(bào)告數(shù)據(jù)").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 '獲取當(dāng)前工作薄所在的路徑
Set wb = GetObject(mypath & "\" & "date.xls") '設(shè)置wb為當(dāng)前目錄下的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
