最近在做水質(zhì)分析數(shù)據(jù)錄入的時(shí)候,，需要根據(jù)監(jiān)測(cè)井編號(hào)到多個(gè)excel表中查詢?cè)摼幪?hào)對(duì)應(yīng)的井的水質(zhì)分析數(shù)據(jù),，并將單口井的水質(zhì)分析數(shù)據(jù)復(fù)制到新表中,。由于檢測(cè)中心給的

水質(zhì)分析數(shù)據(jù)很多，而且還分布在不同的工作薄中,，一個(gè)個(gè)得查詢?cè)購(gòu)?fù)制不僅工作量巨大,、而且容易出錯(cuò)。因此編寫了以下代碼,，讓這部分工作實(shí)現(xiàn)自動(dòng)化,。

這部分內(nèi)容涉及的知識(shí)點(diǎn)有：多工作薄交叉復(fù)制、獲取某一目錄下所有excel工作薄,、獲取某一目錄下所有指定類型excel工作薄,、創(chuàng)建工作薄、打開工作薄并操作

現(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)找到的文件為指定類型的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