【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